Check-in [354986d9c3]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merged with trunk at tag macosx-8-4-merge-2002-08-20-trunk
Timelines: family | ancestors | descendants | both | macosx-8-4-merge-2002-08-20-branch | macosx-8-4-branch
Files: files | file ages | folders
SHA1: 354986d9c394500636d4eac4ef6490bec0540b05
User & Date: das 2002-08-20 20:25:23.000
Context
2002-08-21
12:23
whitespace & other cleanup added support for standard MacOSX tcl package locations check-in: 2c6703cd87 user: das tags: macosx-8-4-branch
2002-08-20
20:25
merged with trunk at tag macosx-8-4-merge-2002-08-20-trunk check-in: 354986d9c3 user: das tags: macosx-8-4-merge-2002-08-20-branch, macosx-8-4-branch
2002-06-28
22:34
Adopting V. Darley's patch from the head. check-in: 7412baeb52 user: wolfsuit tags: macosx-8-4-branch
Changes
Unified Diff Ignore Whitespace Patch
Changes to ChangeLog.




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































2002-06-07  Don Porter  <dgp@users.sourceforge.net>

	* tests/tcltest.test:  More corrections to test suite so that tests
	of failing [test]s don't show up themselves as failing tests.

2002-06-07  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
2002-08-20  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclCkalloc.c:	CONSTified MemoryCmd and CheckmemCmd.

	* README:		Bumped version number to 8.4b3 to distinguish
	* generic/tcl.h:	HEAD from the 8.4b2 release.
	* tools/tcl.wse.in:
	* unix/configure.in:
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure.in:

	* unix/configure:	autoconf
	* win/configure:

	* library/http/http.tcl:	Corrected installation directory of
	* library/msgcat/msgcat.tcl:	the package tcltest 2.2.  Added
	* library/opt/optparse.tcl:	comments in other packages to remind
	* library/tcltest/tcltest.tcl:	that installation directories need 
	* unix/Makefile.in:		updates to match increasing version
	* win/Makefile.in:		numbers. [Bug 597450]
	* win/makefile.bc:
	* win/makefile.vc:

2002-08-19  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/tclUnixTest.c (TestfilehandlerCmd): Changed
	  readable/writable to the more common readable|writable.

	  Fixes SF #596034 reported by Larry Virden
	  <lvirden@users.sourceforge.net>.

2002-08-16  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/fCmd.test: Added test to make sure that the cause of the
	problem is detectable with an unpatched Tcl.
	* doc/ObjectType.3: Added note on the root cause of this problem
	to the documentation, since it is possible for user code to
	trigger this sort of behaviour too.
	* generic/tclIOUtil.c (SetFsPathFromAny): Objects should only have
	their old representation deleted when we know that we are about to
	install a new one.  This stops a weird TclX bug under Linux with
	certain kinds of memory debugging enabled which essentally came
	down to a double-free of a string.

2002-08-14  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclInt.h:
	* generic/tclObj.c: (code cleanup) factored the parts in the macros 
	TclNewObj() / TclDecrRefCount() into a common part for all
	memory allocators and two new macros TclAllocObjStorage() /
	TclFreeObjStorage() that are specific to each allocator and fully
	describe the differences. Removed allocator-specific code from
	tclObj.c by using the macros.
	
2002-08-12  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCmdMZ.c: fixing UMR in delete traces, [Bug 589863].
	
2002-08-08  David Gravereaux <davygrvy@pobox.com>

	* tools/man2help.tcl: Fixed $argv handling bug where if -bitmap
	wasn't specified $argc was off by one.

2002-08-08  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/uplevel.test: added 6.1 to test [uplevel] with shadowed
	commands [Bug 524383]

	* tests/subst.test: added 5.8-10 as further tests for [Bug 495207] 

2002-08-08  Don Porter  <dgp@users.sourceforge.net>

	* tests/README: Noted removal of defs.tcl.

2002-08-08  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/lsearch.n: corrected lsearch docs to use -inline in examples.

	*** 8.4b2 TAGGED FOR RELEASE ***

	* tests/fCmd.test:
	* tests/unixFCmd.test: updated tests for new link copy behavior.
	* generic/tclFCmd.c (CopyRenameOneFile): changed the behavior to
	follow links to endpoints and copy that file/directory instead of
	just copying the surface link.  This means that trying to copy a
	link that has no endpoint (danling link) is an error.
	[Patch #591647] (darley)
	(CopyRenameOneFile): this is currently disabled by default until
	further issues with such behavior (like relative links) can be
	handled correctly.

	* tests/README: slight wording improvements

2002-08-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* docs/BoolObj.3: added description of valid string reps for a
	boolean object [Bug 584794]
	* generic/tclObj.c: optimised Tcl_GetBooleanFromObj and
	SetBooleanFromAny to avoid parsing the string rep when it can be
	avoided [Bugs 584650, 472576]
	
2002-08-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.h:
	* generic/tclObj.c: making tclCmdNameType static ([Bug 584567],
	Don Porter).
	
2002-08-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclObj.c (Tcl_NewObj): added conditional code for
	USE_THREAD_ALLOC; objects allocated through Tcl_NewObj() were
	otherwise being leaked. [Bug 587488] reported by Sven Sass.
	
2002-08-06  Daniel Steffen  <das@users.sourceforge.net>

	* generic/tclInt.decls:
	* unix/tclUnixThrd.c: Added stubs and implementations for
	non-threaded build for the tclUnixThrd.c procs TclpReaddir,
	TclpLocaltime, TclpGmtime and TclpInetNtoa.
	Fixes link errors in stubbed & threaded extensions that include
	tclUnixPort.h and use any of the procs readdir, localtime, 
	gmtime or inet_ntoa (e.g. TclX 8.4) [Bug 589526]
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: Regen.

2002-08-05  Don Porter  <dgp@users.sourceforge.net>

	* library/tcltest/tcltest.tcl:	The setup and cleanup scripts are now
	* library/tcltest/pkgIndex.tcl:	skipped when a test is skipped, fixing
	* tests/tcltest.test:		[Bug 589859].  Test for bug added, and
	corrected tcltest package bumped to version 2.2.

	* generic/tcl.decls:	Restored Tcl_Concat to return (char *).  Like
	* generic/tclDecls.h:	Tcl_Merge, it transfers ownership of a dynamic
	* generic/tclUtil.c:	allocated string to the caller.

2002-08-04  Don Porter  <dgp@users.sourceforge.net>

	* doc/CmdCmplt.3:	Applied Patch 585105 to fully CONST-ify
	* doc/Concat.3:		all remaining public interfaces of Tcl.
	* doc/CrtCommand.3:	Notably, the parser no longer writes on 
	* doc/CrtSlave.3:	the string it is parsing, so it is no
	* doc/CrtTrace.3:	longer necessary for Tcl_Eval() to be
	* doc/Eval.3:		given a writable string.  Also, the
	* doc/ExprLong.3:	refactoring of the Tcl_*Var* routines
	* doc/LinkVar.3:	by Miguel Sofer is included, so that the
	* doc/ParseCmd.3:	"part1" argument for them no longer needs
	* doc/SetVar.3:		to be writable either.
	* doc/TraceVar.3:
	* doc/UpVar.3:		Compatibility support has been enhanced so
	* generic/tcl.decls	that a #define of USE_NON_CONST will remove
	* generic/tcl.h		all possible source incompatibilities with
	* generic/tclBasic.c	the 8.3 version of the header file(s).
	* generic/tclCmdMZ.c	The new #define of USE_COMPAT_CONST now does
	* generic/tclCompCmds.c	what USE_NON_CONST used to do -- disable
	* generic/tclCompExpr.c only those new CONST's that introduce
	* generic/tclCompile.c	irreconcilable incompatibilities.
	* generic/tclCompile.h
	* generic/tclDecls.h	Several bugs are also fixed by this patch.
	* generic/tclEnv.c	[Bugs 584051,580433] [Patches 585105,582429]
	* generic/tclEvent.c	
	* generic/tclInt.decls
	* generic/tclInt.h
	* generic/tclIntDecls.h
	* generic/tclInterp.c
	* generic/tclLink.c
	* generic/tclObj.c
	* generic/tclParse.c
	* generic/tclParseExpr.c
	* generic/tclProc.c
	* generic/tclTest.c
	* generic/tclUtf.c
	* generic/tclUtil.c
	* generic/tclVar.c
	* mac/tclMacTest.c
	* tests/expr-old.test
	* tests/parseExpr.test
	* unix/tclUnixTest.c
	* unix/tclXtTest.c
	* win/tclWinTest.c

2002-08-01  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: bugfix (reading freed memory). Testsuite
	passed on linux/i386, compile-13.1 hung on linux/alpha.

2002-08-01  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: added a reference count for the complete
	execution stack, instead of Tcl_Preserve/Tcl_Release. 

2002-08-01  Mo DeJong  <mdejong@users.sourceforge.net>

	* generic/tclCkalloc.c (TclFinalizeMemorySubsystem):
	Don't lock the ckalloc mutex before invoking the
	Tcl_DumpActiveMemory function since it also
	locks the same mutex. This code is only executed
	when "memory onexit filename" has been executed
	and Tcl is compiled with -DTCL_MEM_DEBUG.

2002-08-01  Reinhard Max  <max@suse.de>

	* win/tclWinPort.h: The windows headers don't provide socklen_t,
	so we have to do it.

2002-07-31  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclInt.h (USE_THREAD_ALLOC): for unshared objects,
	TclDecrRefCount now frees the internal rep before the string rep -
	just like the non-macro Tcl_DecrRefCount/TclFreeObj [Bug 524802]. 
	For the other allocators the fix was done on 2002-03-06.

2002-07-31  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclInterp.c: signed/unsigned comparison warning fixed
	(Vince Darley).

2002-07-31  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tcl.m4 (SC_BUGGY_STRTOD): Enabled caching of test results.

	* unix/tcl.m4 (SC_BUGGY_STRTOD): Solaris 2.8 still has a buggy
	strtod() implementation; make sure we detect it.

	* tests/expr.test (expr-22.*): Marked as non-portable because it
	seems that these tests have an annoying tendency to fail in
	unexpected ways.  [Bugs 584825, 584950, 585986]

2002-07-30  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* tests/io.test: 
	* generic/tclIO.c (WriteChars): Added flag to break out of loop if
	  nothing of the input is consumed at all, to prevent infinite
	  looping of called with a non-UTF-8 string. Fixes Bug 584603
	  (partially). Added new test "io-60.1". Might need additional
	  changes to Tcl_Main so that unprintable results are printed as
	  binary data.

2002-07-29  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Use CC_SEARCH_FLAGS instead of
	LD_SEARCH_FLAGS when linking with ${CC}.
	* unix/configure: Regen.
	* unix/configure.in: Don't subst CC_SEARCH_FLAGS or
	LD_SEARCH_FLAGS since this is now done in tcl.m4.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Document and
	set CC_SEARCH_FLAGS whenever LD_SEARCH_FLAGS is set.
	[Tcl patch 588290]

2002-07-29  Reinhard Max  <max@suse.de>

	* unix/tcl.m4 (SC_SERIAL_PORT): Fixed detection for cases when
                                        configure's stdin is not a tty.
	
	* unix/tclUnixPort.h: 
	* generic/tclIOSock.c:          Changed size_t to socklen_t in
                                        socket-related function calls.

	* unix/configure.in:            Added test and fallback definition
                                        for socklen_t.
	
	* unix/configure:               generated.

2002-07-29  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclObj.c: fixed a comment

	* generic/tcl.h: 
	* generic/tclBasic.c: 
	* generic/tclInterp.c: added the new flag TCL_EVAL_INVOKE to
	the interface of the Tcl_Eval* functions, removing the
	TCL_EVAL_NO_TRACEBACK added yesterday: alias invocations not only 
	require no tracebacks, but also look up the command name in the
	global scope - see new test interp-9.4
	* tests/interp.test: added 9.3 to test for safety of aliases to
	hidden commands, 9.4 to test for correct command lookup scope.

2002-07-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/regc_locale.c (cclass): [[:xdigit:]] is only a defined
	concept on western characters, so should not allow any unicode
	digit, and hence number of ranges in [[:xdigit:]] is fixed.
	* tests/reg.test: Added test to detect the bug.
	* generic/regc_cvec.c (newcvec): Corrected initial size value in
	character vector structure.  [Bug 578363]  Many thanks to
	pvgoran@users.sf.net for tracking this down.

2002-07-28  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tcl.h: 
	* generic/tclBasic.c: added the new flag TCL_EVAL_NO_TRACEBACK to
	the interface of the Tcl_Eval* functions. Modified the error
	message for too many nested evaluations.
	* generic/tclInterp.h: changed the Alias struct to be of variable
	length and store the prefix arguments directly (instead of a
	pointer to a Tcl_Obj list). Made AliasObjCmd call Tcl_EvalObjv
	instead of TclObjInvoke - thus making aliases trigger execution
	traces [Bug 582522].
	* tests/interp.test:
	* tests/stack.test: adapted to the new error message.
	* tests/trace.test: added tests for aliases firing the exec
	traces. 

2002-07-27  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Revert fix for Tcl bug 529801
	since it was incorrect and broke the build on
	other systems. Fix Tcl bug 587299.
	Add MAJOR_VERSION, MINOR_VERSION, PATCH_LEVEL,
	SHLIB_LD_FLAGS, SHLIB_LD_LIBS, CC_SEARCH_FLAGS,
	LD_SEARCH_FLAGS, and LIB_FILE variables to support
	more generic library build/install rules.
	* unix/configure: Regen.
	* unix/configure.in: Move AC_PROG_RANLIB into
	tcl.m4. Move shared build test and setting
	of MAKE_LIB and MAKE_STUB_LIB into tcl.m4.
	Move subst of a number of variables into
	tcl.m4 where they are defined.
	* unix/tcl.m4 (SC_ENABLE_SYMBOLS, SC_CONFIG_CFLAGS):
	Subst vars where they are defined. Add MAKE_LIB,
	MAKE_STUB_LIB, INSTALL_LIB, and INSTALL_STUB_LIB
	rules to deal with the ugly details of running
	ranlib on static libs at build and install time.
	Replace TCL_SHLIB_LD_EXTRAS with SHLIB_LD_FLAGS
	and use it when building a shared library.
	* unix/tclConfig.sh.in: Add TCL_CC_SEARCH_FLAGS.

2002-07-26  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: fixed Tcl_Obj leak in code corresponding
	to the macro NEXT_INST_V(x, 0, 1) [Bug 587495].
	
2002-07-26  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c (TclObjLookupVar): leak fix and improved
	comments. 

2002-07-26  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclVar.c (TclLookupVar): removed early returns that
	prevented the parens from being restored. also removed goto label
	as it was not necessary.

2002-07-24  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: 
	* tests/expr-old.test: fix for erroneous error messages in [expr],
	[Bug  587140] reported by Martin Lemburg.

2002-07-25  Joe English  <jenglish@users.sourceforge.net>
	* generic/tclProc.c: fix for Tk Bug #219218 "error handling 
	with bgerror in Tk"

2002-07-24  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: restoring full TCL_COMPILE_DEBUG
	functionality.

2002-07-24  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test: relaxed unixInit-3.1 to accept iso8859-15
	as a valid C encoding.  [Bug 575336]

2002-07-24  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: restoring the tcl_traceCompile
	functionality while I repair tcl_traceExec. The core now compiles
	and runs also under TCL_COMPILE_DEBUG, but execution in the
	bytecode engine can still not be traced.

2002-07-24  Daniel Steffen  <das@users.sourceforge.net>

	* unix/Makefile.in:
	* unix/configure.in: corrected fix for [Bug 529801]: ranlib
	only needed for static builds on Mac OS X.
	* unix/configure: Regen.
	* unix/tclLoadDyld.c: fixed small bugs introduced by Vince,
	implemented library unloading correctly (needs OS X 10.2).

2002-07-23  Joe English  <jenglish@users.sourceforge.net>

	* doc/OpenFileChnl.3: (Updates from Larry Virden)
	* doc/open.n:
	* doc/tclsh.1: Fix section numbers in Unix man page references.
	* doc/lset.n:  In EXAMPLES section, include command to set the 
	initial value used in subsequent examples.
	* doc/http.n: Package version updated to 2.4.

2002-07-23  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Enable 64 bit compilation
	when using the native compiler on a 64 bit version of IRIX.
	[Tcl bug 219220]

2002-07-23  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Combine ranlib tests and
	avoid printing unless ranlib is actually run.

2002-07-23  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/tcl.m4 (SC_PATH_X): Set XINCLUDES to "" instead
	of "# no special path needed" or "# no include files found"
	when x headers cannot be located.

2002-07-22  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c: made tclNativeFilesystem static
	(since 07-19 changes removed its usage elsewhere), and
	added comments about its usage.
	* generic/tclLoad.c:
	* generic/tcl.h:
	* generic/tcl.decls: 
	* doc/FileSystem.3: converted last load-related ClientData
	parameter to Tcl_LoadHandle opaque structure, removing a 
	couple of casts in the process.
	
	* generic/tclInt.h: removed tclNativeFilesystem declaration
	since it is now static again.
	
2002-07-22  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/expr.test (expr-22.*): Added tests to help detect the
	corrected handling.
	* generic/tclExecute.c (IllegalExprOperandType): Improved error
	message generated when attempting to manipulate Inf and NaN values.
	* generic/tclParseExpr.c (GetLexeme): Allowed parser to recognise
	'Inf' as a floating-point number. [Bug 218000]

2002-07-21  Don Porter  <dgp@users.sourceforge.net>

	* tclIOUtil.c: Silence compiler warning. [Bug 584408].

2002-07-19  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c: fix to GetFilesystemRecord
	* win/tclWinFile.c:
	* unix/tclUnixFile.c: fix to subtle problem with links shown
	up by latest tclkit builds.

2002-07-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure:
	* unix/configure.in:
	* win/configure:
	* win/configure.in: Add AC_PREREQ(2.13) in an attempt
	to make it more clear that the configure scripts
	must be generated with autoconf version 2.13.
	[Bug 583573]

2002-07-19  Vince Darley  <vincentdarley@users.sourceforge.net>

	* unix/Makefile.in: fix to build on MacOS X [Bug 529801], bug
	report and fix from jcw.

2002-07-19  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* win/tclWinSerial.c (no_timeout): Made this variable static.

	* generic/tclExecute.c, generic/tclCompile.c, generic/tclBasic.c: 
	* generic/tclCompile.h (builtinFuncTable, instructionTable): Added
	prefix to these symbols because they are visible outside the Tcl
	library.

	* generic/tclCompExpr.c (operatorTable): 
	* unix/tclUnixTime.c (tmKey):
	* generic/tclIOUtil.c (theFilesystemEpoch, filesystemWantToModify,
	filesystemIteratorsInProgress, filesystemOkToModify): Made these
	variables static.

	* unix/tclUnixFile.c:		Renamed nativeFilesystem to
	* win/tclWinFile.c:		tclNativeFilesystem and declared
	* generic/tclIOUtil.c:		it properly in tclInt.h
	* generic/tclInt.h: 

	* generic/tclUtf.c (totalBytes): Made this array static and const.

	* generic/tclParse.c (typeTable): Made this array static and const.
	(Tcl_ParseBraces): Simplified error handling case so that scans
	are only performed when needed, and flags are simpler too.

	* license.terms: Added AS to list of copyright holders; it's only
	fair for the current gatekeepers to be listed here!

	* tests/cmdMZ.test: Renamed constraint for clarity. [Bug#583427]
	Added tests for the [time] command, which was previously only
	indirectly tested!

2002-07-18  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclInt.h:
	* generic/tcl.h:
	* */*Load*.c: added comments on changes of 07/17 and 
	replaced clientData with Tcl_LoadHandle in all locations.

	* generic/tclFCmd.c:
	* tests/fileSystem.test: fixed a 'knownBug' with 'file
	attributes ""'
	* tests/winFCmd.test: 
	* tests/winPipe.test:
	* tests/fCmd.test:
	* tessts/winFile.test: added 'pcOnly' constraint to some
	tests to make for more useful 'tests skipped' log from 
	running all tests on non-Windows platforms.
	
2002-07-17  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c (CallCommandTraces): delete traces now
	receive the FQ old name of the command. 
	[Bug 582532] (Don Porter)

2002-07-18  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/ioUtil.test: added constraints to 1.4,2.4 so they
	don't run outside of tcltest. [Bugs 583276,583277]
	
2002-07-17  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c (DupParsedVarName): nasty bug fixed, reported
	by Vince Darley.

2002-07-17  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c (TclPtrIncrVar): missing CONST in declarations,
	inconsistent with tclInt.h. Thanks to Vince Darley for reporting,
	boo to gcc for not complaining.
	
2002-07-17  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclInt.h:
	* generic/tclIOUtil.c:
	* generic/tclLoadNone.c:
	* unix/tclLoadAout.c:
	* unix/tclLoadDl.c:
	* unix/tclLoadDld.c:
	* unix/tclLoadDyld.c:
	* unix/tclLoadNext.c:
	* unix/tclLoadOSF.c:
	* unix/tclLoadShl.c:
	* mac/tclMacLoad.c:
	* win/tclWinLoad.c: modified to move more functionality
	to the generic code and avoid duplication.  Partial replacement
	of internal uses of clientData with opaque Tcl_LoadHandle.  A
	little further work still needed, but significant changes are done.

2002-07-17  D. Richard Hipp    <drh@hwaci.com>

	* library/msgcat/msgcat.tcl: fix a comment that was causing
	problems for programs (ex: mktclapp) that embed the initialization
	scripts in strings.

2002-07-17  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclInt.decls:
	* generic/tclIntDecls.h:
	* generic/tclStubInit.c:
	* generic/tclVar.c: removing the now redundant functions to access
	indexed variables: Tcl(Get|Set|Incr)IndexedScalar() and
	Tcl(Get|Set|Incr)ElementOfIndexedArray(). 

2002-07-17  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclExecute.c (TclExecuteByteCode): Minor fixes to make
	this file compile with SunPro CC...

2002-07-17  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: modified to do variable lookup explicitly,
	and then either inlining the variable access or else calling the new
	TclPtr(Set|Get|Incr)Var functions in tclVar.c
	* generic/tclInt.h: declare some functions previously local to
	tclVar.c for usage by TEBC.
	* generic/tclVar.c: removed local declarations; moved all special
	accessor functions for indexed variables to the end of the file -
	they are unused and ready for removal, but left there for the time
	being as they are in the internal stubs table.

	** WARNING FOR BYTECODE MAINTAINERS **
	TCL_COMPILE_DEBUG is currently not functional; will be fixed ASAP.
	
2002-07-16  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in: Add a more descriptive warning
	in the event `make genstubs` needs to be rerun.

2002-07-16  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Use dltest.marker file
	to keep track of when the dltest package
	is up to date. This fixes [Tcl bug 575768]
	since tcltest is no longer linked every time.
	* unix/dltest/Makefile.in: Create ../dltest.marker
	after a successful `make all` run in dltest.

2002-07-16  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/configure.in: Remove useless subst of TCL_BIN_DIR.

2002-07-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: inaccurate comment fixed
	
2002-07-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c (Tcl_AddObjErrorInfo):
	* generic/tclExecute.c (TclUpdateReturnInfo):
	* generic/tclInt.h:	
	* generic/tclProc.c: 
	Added two Tcl_Obj to the ExecEnv structure to hold the fully
	qualified names "::errorInfo" and "::errorCode" to cache the
	addresses of the corresponding variables. The two most frequent
	setters of these variables now profit from the new variable name
	caching. 

2002-07-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: refactorisation to reuse already looked-up Var
	pointers; definition of three new Tcl_Obj types to cache variable
	name parsing and lookup for later reuse; modification of internal
	functions to profit from the caching. 
	
	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclIntDecls.h:
	* generic/tclNamesp.c: adding CONST qualifiers to variable names
	passed to Tcl_FindNamespaceVar and to variable resolvers; adding
	CONST qualifier to the 'msg' argument to TclLookupVar. Needed to
	avoid code duplication in the new tclVar.c code.

	* tests/set-old.test:
	* tests/var.test: slight modification of error messages due to the
	modifications in the tclVar.c code.

2002-07-15  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test:	Improved constraints to protect /tmp.	
	  [Bug 581403]

2002-07-15  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/winFCmd.test: renamed 'win2000' and 'notWin2000' to
	more appropriate constraint names.
	* win/tclWinFile.c: updated comments to reflect 07-11 changes.
	* win/tclWinFCmd.c: made ConvertFileNameFormat static again,
	since no longer used in tclWinFile.c
	* mac/tclMacFile.c: completed TclpObjLink implementation which
	was previously lacking.
	* generic/tclIOUtil.c: comment cleanup and code speedup.
	
2002-07-14  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclInt.h:	Removed declarations that duplicated entries
	  in the (internal) stub table.
	
	* library/tcltest/tcltest.tcl:  Corrected errors in handling of
	  configuration options -constraints and -limitconstraints.

	* README:		Bumped HEAD to version 8.4b2 so we can
	* generic/tcl.h:	distinguish it from the 8.4b1 release.
	* tools/tcl.wse.in:
	* unix/configure*:
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure*:

2002-07-11  Vince Darley  <vincentdarley@users.sourceforge.net>

	* doc/file.n:
	* win/tclWinFile.c: on Win 95/98/ME the long form of the path
	is used as a normalized form.  This is required because short
	forms are not a robust representation.  The file normalization
	function has been sped up, but more performance gains might be
	possible, if speed is still an issue on these platforms.

2002-07-11  Don Porter  <dgp@users.sourceforge.net>

	* library/tcltest/tcltest.tcl: Corrected reaction to existing but
	false ::tcl_interactive.

	* doc/Hash.3: Overlooked CONST documentation update.

2002-07-11  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCkalloc.c: ckalloc() and friends take the block size
	as an unsigned, so we should use %ud when reporting it in fprintf()
	and panic().

2002-07-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.c: now setting local vars undefined at
	compile time, instead of waiting until the proc is initialized. 
	* generic/tclProc.c: use macro TclSetVarUndefined instead of
	directly etting the flag.

2002-07-11  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdAH.test: [file attr -perm] is Unix-only, so add [catch]
	when not inside a suitably-protected test.

2002-07-10  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixFCmd.test, tests/fileName.test: 
	* tests/fCmd.test: Removed [exec] of Unix utilities that have
	equivalents in standard Tcl.  [Bug 579268]  Also simplified some
	of unixFCmd.test while I was at it.

2002-07-10  Don Porter  <dgp@users.sourceforge.net>

	* tests/tcltest.test:  Greatly reduced the number of [exec]s, using
	slave interps instead.
	* library/tcltest/tcltest.tcl:  Fixed bug uncovered in the conversion
	where a message was written to stdout instead of [outputChannel].

	* tests/basic.test:	Cleaned up, constrained, and reduced the
	* tests/compile.test:	amount of [exec] usage in the test suite.
	* tests/encoding.test:
	* tests/env.test:
	* tests/event.test:
	* tests/exec.test:
	* tests/io.test:
	* tests/ioCmd.test:
	* tests/regexp.test:
	* tests/regexpComp.test:
	* tests/socket.test:
	* tests/tcltest.test:
	* tests/unixInit.test:
	* tests/winDde.test:
	* tests/winPipe.test:

2002-07-10  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdAH.test: Removed [exec] of Unix utilities. [Bug 579211]

	* tests/expr.test: Added tests to make sure that this works.
	* generic/tclExecute.c (ExprCallMathFunc): Functions should also
	be able to return wide-ints.  [Bug 579284]

2002-07-08  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* tests/socket.test: Fixed bug #578164. The original reason for
	  the was a DNS outage while running the testsuite. Changed [info
	  hostname] to 127.0.0.1 to bypass DNS, knowing that we operate on
	  the local host.

2002-07-08  Don Porter  <dgp@users.sourceforge.net>

	* doc/tcltest.n:		Fixed incompatibility in [viewFile].
	* library/tcltest/tcltest.tcl:	Corrected docs.  Bumped to 2.2.1.
	* library/tcltest/pkgIndex.tcl: [Bug 578163]

2002-07-08  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/cmdAH.test:
	* tests/fCmd.test:
	* tests/fileName.test: tests which rely on 'file link' need a
	constraint so they don't run on older Windows OS. [Bug 578158]
	* generic/tclIOUtil.c:
	* generic/tcl.h:
	* generic/tclInt.h:
	* generic/tclTest.c:
	* mac/tclMacChan.c:
	* unix/tclUnixChan.c:
	* win/tclWinChan.c:
	* doc/FileSystem.3: cleaned up internal handling of
	Tcl_FSOpenFileChannel to remove duplicate code, and make
	writing external vfs's clearer and easier.  No
	functionality change.  Also clarify that objects with refCount
	zero should not be passed in to the Tcl_FS API, and prevent
	segfaults from occuring on such user errors. [Bug 578617]
	
2002-07-06  Don Porter  <dgp@users.sourceforge.net>

	* tests/pkgMkIndex.test:  Constrained tests of [load] package indexing
	to those platforms where the testing shared libraries have been built.
	[Bug 578166].

2002-07-05  Don Porter  <dgp@users.sourceforge.net>
	* changes: added recent changes

2002-07-05  Reinhard Max  <max@suse.de>

	* generic/tclClock.c (FormatClock): Convert the format string to
	UTF8 before calling TclpStrftime, so that non-ASCII characters
	don't get mangled when the result string is being converted back.
	* tests/clock.test: Added a test for that.

2002-07-05  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/Makefile.in (ro-test,ddd,GDB,DDD): Created new targets to
	allow running the test suite with a read-only current directory,
	running under ddd instead of gdb, and factored out some executable
	names for broken sites (like mine) where gdb and ddd are installed
	with non-standard names...

	* tests/httpold.test: Altered test names to httpold-* to avoid
	clashes with http.test, and stopped tests from failing when the
	current directory is not writable...

	* tests/event.test:		Stop these tests from failing
	* tests/ioUtil.test:		when the current directory is
	* tests/regexp.test:		not writable...
	* tests/regexpComp.test: 
	* tests/source.test: 
	* tests/unixFile.test: 
	* tests/unixNotfy.test: 

	* tests/unixFCmd.test:		Trying to make these test-files
	* tests/macFCmd.test:		not bomb out with an error when
	* tests/http.test:		the current directory is not
	* tests/fileName.test:		writable...
	* tests/env.test:

2002-07-05  Jeff Hobbs  <jeffh@ActiveState.com>

	*** 8.4b1 TAGGED FOR RELEASE ***

2002-07-04  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdMZ.test (cmdMZ-1.4): 
	* tests/cmdAH.test: More fixing of writable-current-dir
	assumption. [Bug 575824]

2002-07-04  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/basic.test: Same issue as below; fixed [Bug 575817]
	
2002-07-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* tests/socket.test: 
	* tests/winPipe.test: 
	* tests/pid.test: Fixed SF Bug #575848. See below for a
	  description the general problem.

	* All the bugs below are instances of the same problem: The
	  testsuite assumes [pwd] = [temporaryDirectory] and writable.

	* tests/iogt.test: Fixed bug #575860.
	* tests/io.test:   Fixed bug #575862.
	* tests/exec.test: 
	* tests/ioCmd.test: Fixed bug #575836.

2002-07-03  Don Porter  <dgp@users.sourceforge.net>

	* tests/pkg1/direct1.tcl: removed
	* tests/pkg1/pkgIndex.tcl: removed
	* tests/pkgMkIndex.test:  Imported auxilliary files from tests/pkg1
	  into the test file pkgMkIndex.test itself.  Formatting fixes.

	* unix/Makefile.in: removed tests/pkg/* from `make dist`

	* tests/pkg/circ1.tcl: removed
	* tests/pkg/circ2.tcl: removed
	* tests/pkg/circ3.tcl: removed
	* tests/pkg/global.tcl: removed
	* tests/pkg/import.tcl: removed
	* tests/pkg/pkg1.tcl: removed
	* tests/pkg/pkg2_a.tcl: removed
	* tests/pkg/pkg2_b.tcl: removed
	* tests/pkg/pkg3.tcl: removed
	* tests/pkg/pkg4.tcl: removed
	* tests/pkg/pkg5.tcl: removed
	* tests/pkg/pkga.tcl: removed
	* tests/pkg/samename.tcl: removed
	* tests/pkg/simple.tcl: removed
	* tests/pkg/spacename.tcl: removed
	* tests/pkg/std.tcl: removed
	* tests/pkgMkIndex.test: Fixed [Bug 575857] where this test file
	  expected to be able to write to [file join [testsDirectory]
	  pkg].  Part of the fix was to import several auxilliary files
	  into the test file itself.

	* tests/main.test:	Cheap fix for [Bugs 575851, 575858].  Avoid
	* tests/tcltest.test:	non-writable . by [cd [temporaryDirectory]].

	* library/auto.tcl: Fix [tcl_findLibrary] to be sure it sets
	  $varName only if a successful library script is found.
	  [Bug 577033]

2002-07-03  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c (TclCompileCatchCmd): return
	  TCL_OUT_LINE_COMPILE instead of TCL_ERROR: let the failure
	  happen at runtime so that it can be caught [Bug 577015].

2002-07-02  Joe English  <jenglish@users.sourceforge.net>

	* doc/tcltest.n: Markup fixes, spellcheck.

2002-07-02  Don Porter  <dgp@users.sourceforge.net>

	* doc/tcltest.n: more refinements of the documentation.

	* library/tcltest/tcltest.tcl: Added trace to be sure the stdio
	  constraint is updated whenever the [interpreter] changes.

	* doc/tcltest.n:		Reverted [makeFile] and [viewFile] to
	* library/tcltest/tcltest.tcl:	their former behavior, and documented
	* tests/cmdAH.test:		it.  Corrected misspelling of hook
	* tests/event.test:		procedure.  Restored tests.
	* tests/http.test:
	* tests/io.test:

	* library/tcltest/tcltest.tcl: Simplified logic of
	  [GetMatchingFiles] and [GetMatchingDirectories], removing
	  special case processing.

	* doc/tcltest.n: More documentation updates.  Reference sections
	  are complete.  Only examples need adding.

2002-07-02  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/fCmd.test: 
	* generic/tclCmdAH.c: clearer error msgs for 'file link',
	as per the man page.

2002-07-01  Joe English  <jenglish@users.sourceforge.net>

	* doc/Access.3:
	* doc/AddErrInfo.3:
	* doc/Alloc.3:
	* doc/Backslash.3:
	* doc/CrtChannel.3:
	* doc/CrtSlave.3:
	* doc/Encoding.3:
	* doc/Eval.3:
	* doc/FileSystem.3:
	* doc/Notifier.3:
	* doc/OpenFileChnl.3:
	* doc/ParseCmd.3:
	* doc/RegExp.3:
	* doc/Tcl_Main.3:
	* doc/Thread.3:
	* doc/TraceCmd.3:
	* doc/Utf.3:
	* doc/WrongNumArgs.3:
	* doc/binary.n:
	* doc/clock.n:
	* doc/expr.n:
	* doc/fconfigure.n:
	* doc/glob.n:
	* doc/http.n:
	* doc/interp.n:
	* doc/lsearch.n:
	* doc/lset.n:
	* doc/msgcat.n:
	* doc/packagens.n:
	* doc/pkgMkIndex.n:
	* doc/registry.n:
	* doc/resource.n:
	* doc/safe.n:
	* doc/scan.n:
	* doc/tclvars.n:  Spell-check, fixed typos (Updates from Larry Virden).

2002-07-01  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Made Solaris use gcc for linking
	when building with gcc to resolve problems with undefined symbols
	being present when tcl library used with non-gcc linker at later
	stage. Symbols were compiler-generated, so it is the compiler's
	business to define them. [Bug #541181] 

2002-07-01  Don Porter  <dgp@users.sourceforge.net>

	* doc/tcltest.n: more work in progress updating tcltest docs.

	* library/tcltest/tcltest.tcl: Change [configure -match] to
	stop treating an empty list as a list of the single pattern "*".
	Changed the default value to [list *] so default operation
	remains the same.

	* tests/pkg/samename.tcl: restored.  needed by pkgMkIndex.test.

	* library/tcltest/tcltest.tcl: restored writeability testing of
	-tmpdir, augmented by a special exception for the deafault value.

2002-07-01  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/concat.n: Documented the *real* behaviour of [concat]!

2002-06-30  Don Porter  <dgp@users.sourceforge.net>

	* doc/tcltest.n: more work in progress updating tcltest docs.

	* tests/README:		Updated the instructions on running and
	* tests/cmdMZ.test:	adding to the test suite.  Also updated
	* tests/encoding.test:	several tests, mostly to correctly create
	* tests/fCmd.test:	and destroy any temporary files in the
	* tests/info.test:	[temporaryDirectory] of tcltest.
	* tests/interp.test:

	* library/tcltest/tcltest.tcl:	Stopped checking for writeability
	of -tmpdir value because no default directory can be guaranteed to
	be writeable.

	* tests/autoMkindex.tcl: removed.
	* tests/pkg/samename.tcl: removed.
	* tests/pkg/magicchar.tcl: removed.
	* tests/pkg/magicchar2.tcl: removed.
	* tests/autoMkindex.test: Updated auto_mkIndex tests to use
	[makeFile] and [removeFile] so tests are done in [temporaryDirecotry]
	where write access is guaranteed.

	* library/tcltest/tcltest.tcl:	Fixed [makeFile] and [viewFile] to
	* tests/cmdAH.test:		accurately reflect a file's contents.
	* tests/event.test:		Updated tests that depended on buggy
	* tests/http.test:		behavior.  Also added warning messages
	* tests/io.test:		to "-debug 1" operations to debug test
	* tests/iogt.test:		calls to (make|remove)(File|Directory).

	* unix/mkLinks: `make mklinks` on 6-27 commits.

2002-06-28  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.h: modified the macro TclEmitPush to not
	call its first argument repeatedly or pass it to other macros,
	[Bug 575194] reported by Peter Spjuth.

2002-06-28  Don Porter  <dgp@users.sourceforge.net>

	* docs/tcltest.n:	Doc revisions in progress.
	* library/tcltest/tcltest.tcl: Corrected -testdir default value.
	Was not reliable, and disagreed with docs!  Thanks to Hemang Lavana.
	[Bug 575150]

2002-06-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tclUnixThrd.c:	Renamed the Tcl_Platform* #defines to
	* unix/tclUnixPipe.c:	TclOS* because they are only used
	* unix/tclUnixFile.c:	internally.  Also stopped double-#def
	* unix/tclUnixFCmd.c:	of TclOSlstat [Bug #566099, post-rename]
	* unix/tclUnixChan.c:
	* unix/tclUnixPort.h:

	* doc/string.n: Improved documentation for [string last] along
	lines described in Bug #574799 so it indicates that the supplied
	index marks the end of the search space.

2002-06-27  Don Porter  <dgp@users.sourceforge.net>

	* doc/dde.n:		Work in progress updating the documentation
	* doc/http.n:		of the packages that come bundled with
	* doc/msgcat.n:		the Tcl source distribution, notably tcltest.
	* doc/registry.n:
	* doc/tcltest.n:

	* library/tcltest/tcltest.tcl:  Made sure that the TCLTEST_OPTIONS
	environment variablle configures tcltest at package load time.

2002-06-26  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/fileSystem.test: 
	* generic/tclIOUtil.c: fix to handling of empty paths ""
	which are not claimed by any filesystem (Bug #573758).
	Ensure good error messages are given in all cases.
	* tests/cmdAH.test:
	* unix/tclUnixFCmd.c: fix to bug reported as part of
	(Patch #566669).  Thanks to Taguchi, Takeshi for the report.
	
2002-06-26  Reinhard Max  <max@suse.de>

	* unix/tclUnixTime.c: Make [clock format] respect locale settings.
	* tests/clock.test:   Bug #565880. ***POTENTIAL INCOMPATIBILITY***

2002-06-26  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/CrtInterp.3:
	* doc/StringObj.3: clarifications by Don Porter, bugs #493995 and
	#500930. 
	
2002-06-24  Don Porter  <dgp@users.sourceforge.net>

	* library/tcltest/tcltest.tcl:	Corrected suppression of -verbose skip
	* tests/tcltest.test:		and start by [test -output].  Also
	corrected test suite errors exposed by corrected code.  [Bug 564656]

2002-06-25  Reinhard Max  <max@suse.de>

	* unix/tcl.m4:       New macro SC_CONFIG_MANPAGES.
	* unix/configure.in: Added support for symlinks and compression
	* unix/Makefile.in:  when installing the manpages. [Patch 518052]
	* unix/mkLinks.tcl:  Default is still hardlinks and no compression.

	* unix/mkLinks:      generated
	* unix/configure:

	* unix/README:       Added documentation for the new features.

	* unix/tcl.m4 (SC_PATH_TCLCONFIG): Replaced ${exec_prefix}/lib by
	${libdir}.

2002-06-25  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclUtil.c (TclGetIntForIndex): Fix of critical bug
	#533364 generated when the index is bad and the result is a shared
	object.  The T_ASTO(T_GOR, ...) idiom likely exists elsewhere
	though.  Also removed some cruft that just complicated things to
	no advantage.
	(SetEndOffsetFromAny): Same fix, though this wasn't on the path
	excited by the bug.

2002-06-24  Don Porter  <dgp@users.sourceforge.net>

	* library/tcltest/tcltest.tcl:	Implementation of TIP 101.  Adds
	* tests/parseOld.test:		and exports a [configure] command
	* tests/tcltest.test:		from tcltest.

2002-06-22  Don Porter  <dgp@users.sourceforge.net>

	* changes: updated changes file for 8.4b1 release.

	* library/tcltest/tcltest.tcl:	Corrections to tcltest and the
	* tests/basic.test:		Tcl test suite so that a test
	* tests/cmdInfo.test:		with options -constraints knownBug
	* tests/compile.test:		-limitConstraints 1 only tests the
	* tests/encoding.test:		knownBug tests.  Mostly involves
	* tests/env.test:		replacing direct access to the
	* tests/event.test:		testConstraints array with calls
	* tests/exec.test:		to the testConstraint command
	* tests/execute.test:		(which requires tcltest version 2)
	* tests/fCmd.test:
	* tests/format.test:
	* tests/http.test:
	* tests/httpold.test:
	* tests/ioUtil.test:
	* tests/link.test:
	* tests/load.test:
	* tests/namespace.test:
	* tests/pkgMkIndex.test:
	* tests/reg.test:
	* tests/result.test:
	* tests/scan.test:
	* tests/stack.test:

2002-06-22  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tools/tcl.wse.in (Disk Label), unix/tcl.spec (version): 
	* win/README.binary, README, win/configure.in, unix/configure.in: 
	* generic/tcl.h (TCL_RELEASE_*, TCL_PATCH_LEVEL): Bump to beta1.

2002-06-21  Joe English  <jenglish@users.sourceforge.net>

	* generic/tclCompExpr.c:
	* generic/tclParseExpr.c: LogSyntaxError() should reset 
	the interpreter result [Bug 550142 "Tcl_ExprObj -> abort"] 

2002-06-21  Don Porter  <dgp@users.sourceforge.net>
	
	* unix/Makefile.in:	Updated all package install directories
	* win/Makefile.in:	to match current Major.minor versions
	* win/makefile.bc:	of the packages.  Added tcltest package
	* win/makefile.vc:	to installation on Windows.

	* library/init.tcl:  Corrected comments and namespace style
	issues.  Thanks to Bruce Stephens. [Bug 572025]

2002-06-21  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/cmdAH.test:          Added TIP#99 implementation
	* tests/fCmd.test:           of 'file link'.  Supports creation
	* tests/fileName.test:       of symbolic and hard links in the
	* tests/fileSystem.test:     native filesystems and in vfs's,
	* generic/tclTest.c:         when the individual filesystem
	* generic/tclCmdAH.c:        supports the concept.
	* generic/tclIOUtil.c:       
	* generic/tcl.h:
	* generic/tcl.decls:
	* doc/FileSystem.3:
	* doc/file.n:
	* mac/tclMacFile.c:
	* unix/tclUnixFile.c:
	* win/tclWinFile.c: Also enhanced speed of 'file normalize' on
	Windows.

2002-06-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c (TclEvalObjvInternal): fix for [Bug 571385]
	in the implementation of TIP#62 (command tracing). Vince Darley,
	Hemang Lavana & Don Porter: thanks.

2002-06-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TclCompEvalObj): clarified and simplified
	the logic for compilation/recompilation.

2002-06-19  Joe English  <jenglish@users.sourceforge.net>
	* doc/file.n: Fixed indentation.  No substantive changes.

2002-06-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): get the resultPtr again
	as the Tcl_ObjSetVar2 may cause the result to change.
	[Patch #558324] (watson)

2002-06-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TEBC): removing unused "for(;;)" loop;
	improved comments; re-indentation.

2002-06-18  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TEBC): 
	- elimination of duplicated code in the non-immediate INST_INCR
	  instructions. 
	- elimination of 103 (!) TclDecrRefCount macros. The different
	  instructions now jump back to a common "DecrRefCount zone" at
	  the top of the loop. The macro "ADJUST_PC" was replaced by two
	  macros "NEXT_INST_F" and "NEXT_INST_V" that take three params
	  (pcAdjustment, # of stack objects to discard, resultObjPtr
	  handling flag). The only instructions that retain a
	  TclDecrRefCount are INST_POP (for speed), the common code for
	  the non-immediate INST_INCR, INST_FOREACH_STEP and the two
	  INST_LSET.

	The object size of tclExecute.o was reduced by approx 20% since
	the start of the consolidation drive, while making room for some
	peep-hole optimisation at runtime.

2002-06-18  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TEBC, INST_DONE): small bug in the panic
	code for tcl-stack corruption.

2002-06-17  David Gravereaux <davygrvy@pobox.com>

	Trims to support the removal of RESOURCE_INCLUDED from rc
	scripts	from FR #565088.

	* generic/tcl.h: moved the #ifndef RC_INVOKED start block up in
	the file.  rc scripts don't need to know thread mutexes.

	* win/tcl.rc:
	* win/tclsh.rc: removed the #define RESOURCE_INCLUDED to let the
	built-in -DRC_INVOKED to the work.

2002-06-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/CrtTrace.3:        Added TIP#62 implementation of command
	* doc/trace.n:           execution tracing [FR #462580] (lavana).
	* generic/tcl.h:         This includes enter/leave tracing as well
	* generic/tclBasic.c:    as inter-procedure stepping.
	* generic/tclCmdMZ.c:
	* generic/tclCompile.c:
	* generic/tclExecute.c:
	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclIntDecls.h:
	* generic/tclStubInit.c:
	* generic/tclVar.c:
	* tests/trace.test:

2002-06-17  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* win/tclWinPipe.c (BuildCommandLine): Fixed bug #554068 ([exec]
	  on windows did not treat { in filenames well.). Bug reported by
	  Vince Darley <vincentdarley@users.sourceforge.net>, patch
	  provided by Vince too.

2002-06-17  Joe English  <jenglish@users.sourceforge.net>

	* generic/tcl.h: #ifdef logic for K&R C backwards compatibility
	changed to assume modern C by default.  See SF FR #565088 for
	full details.

2002-06-17  Don Porter  <dgp@users.sourceforge.net>

	* doc/msgcat.n: Corrected en_UK references to en_GB.  UK is not
	a country designation recognized in ISO 3166.

	* library/msgcat/msgcat.tcl:  More Windows Registry locale codes
	from Bruno Haible.

	* doc/msgcat.n:
	* library/msgcat/msgcat.tcl:
	* library/msgcat/pkgIndex.tcl:
	* tests/msgcat.test:  Revised locale initialization to interpret
	environment variable locale values according to XPG4, and to
	recognize the LC_ALL and LC_MESSAGES values over that of LANG.
	Also added many Windows Registry locale values to those 
	recognized by msgcat.  Revised tests and docs.  Bumped to
	version 1.3.  Thanks to Bruno Haible for the report and
	assistance crafting the solution.  [Bug 525522, 525525]

2002-06-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.c (TclCompileTokens): a better algorithm for
	the previous bug fix.

2002-06-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.c (TclCompileTokens): 
	* tests/compile.test: [Bug 569438] in the processing of dollar
	variables; report by Georgios Petasis. 
	
2002-06-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: bug in the consolidation of the
	INCR_..._STK instructions; the bug could not be exercised as the
	(faulty) instruction INST_INCR_ARRAY_STK was never compiled-in
	(related to [Bug 569438]).

2002-06-14  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole
	optimisation of variables (INST_STORE, INST_INCR) and commands
	(INST_INVOKE); faster check for the existence of a catch.
	(TclExecuteByteCode): runtime peep-hole optimisation of
	comparisons.
	(TclExecuteByteCode): runtime peep-hole optimisation of
	INST_FOREACH - relies on peculiarities of the code produced by the
	bytecode compiler.

2002-06-14  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc: The test for compiler optimizations was in error.
	Thanks goes to Roy Terry <royterry@earthlink.net> for his
	assistance with this.

2002-06-14  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/trace.n, tests/trace.test: 
	* generic/tclCmdMZ.c (Tcl_TraceObjCmd,TclTraceCommandObjCmd)
	(TclTraceVariableObjCmd): Changed references to "trace list" to
	"trace info" as mandated by TIP#102.

2002-06-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TclExecuteByteCode): consolidated code for
	the conditional branch instructions.

2002-06-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TclExecuteByteCode): fixed the previous
	patch - wouldn't compile with TCL_COMPILE_DEBUG set.

2002-06-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TclExecuteByteCode): consolidated the
	handling of exception returns to INST_INVOKE and INST_EVAL, as
	well as most of the code for INST_CONTINUE and INST_BREAK, in the
	new jump target "processExceptionReturn".

2002-06-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c (TclExecuteByteCode): consolidated variable
	handling opcodes, replaced redundant code with some 'goto'. All
	store/append/lappend opcodes on the same data type now share the
	main code; same with incr opcodes.
	* generic/tclVar.c: added the bit TCL_TRACE_READS to the possible
	flags to Tcl_SetVar2Ex - it causes read traces to be fired prior
	to setting the variable. This is used in the core for [lappend].

	***NOTE*** the usage of TCL_TRACE_READS in Tcl_(Obj)?GetVar.* is
	not documented; there, it causes the call to create the variable
	if it does not exist. The new usage in Tcl_(Obj)?SetVar.* remains
	undocumented too ...
	
2002-06-13  Vince Darley  <vincentdarley@users.sourceforge.net>

	* tests/fCmd.test:
	* tests/winFile.test:
	* tests/fileSystem.test:
	* generic/tclTest.c:
	* generic/tclCmdAH.c:
	* generic/tclIOUtil.c:
	* doc/FileSystem.3:
	* mac/tclMacFile.c:
	* unix/tclUnixFile.c:
	* win/tclWinFile.c: fixed up further so both compiles and
	actually works with VC++ 5 or 6.
	* win/tclWinInt.h: 
	* win/tclWin32Dll.c: cleaned up code and vfs tests and
	added tests for the internal changes of 2002-06-12, to see
	whether WinTcl on NTFS can coexist peacefully with links
	in the filesystem.  Added new test command 'testfilelink'
	to enable the newer code to be tested.
	* tests/fCmd.test: (made certain tests of 'testfilelink' not
	run on unix).

2002-06-12  Miguel Sofer  <msofer@users.sourceforge.net>

	* tclBasic.c (Tcl_DeleteTrace): fixed [Bug 568123] (thanks to
	Hemang Lavana)
	
2002-06-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinFile.c: corrected the symbolic link handling code to
	allow it to compile.  Added real definition of REPARSE_DATA_BUFFER
	(found in winnt.h).  Most of the added definitions appear to have
	correct, cross-Win-version equivalents in winnt.h and should be
	removed, but just making things "work" for now.

2002-06-12  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c:
	* generic/tcl.decls:
	* generic/tclDecls.h: made code for Tcl_FSNewNativePath
	agree with man pages.
	
	* doc/FileSystem.3: clarified the circumstances under which
	certain functions are called in the presence of symlinks.
	
	* win/tclWinFile.c:
	* win/tclWinPort.h: 
	* win/tclWinInt.h: 
	* win/tclWinFCmd.c:  Fix for Windows to allow 'file lstat', 
	'file type', 'glob -type l', 'file copy', 'file delete', 
	'file normalize', and all VFS code to work correctly in the 
	presence of symlinks (previously Tcl's behaviour was not very 
	well defined).  This also fixes possible serious problems in 
	all versions of WinTcl where 'file delete' on a NTFS symlink 
	could delete the original, not the symlink.
	Note: symlinks cannot yet be created in pure Tcl.

2002-06-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c: 
	* generic/tclCompCmds.c:
	* generic/tclInt.h: reverted the new compilation functions;
	replaced by a more general approach described below.

	* generic/tclCompCmds.c:
	* generic/tclCompile.c: made *all* compiled variable access
	attempts create an indexed variable - even get or incr without
	previous set. This allows indexed access to local variables that
	are created and set at runtime, for example by [global], [upvar],
	[variable], [regexp], [regsub].

2002-06-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/global.n:
	* doc/info.n:
	* test/info.test:
	* generic/tclCmdIL.c: fix for [Bug 567386], [info locals] was
	reporting some linked variables.
	
	* generic/tclBasic.c: 
	* generic/tclCompCmds.c:
	* generic/tclInt.h: added compile functions for [global],
	[variable] and [upvar]. They just declare the new local variables,
	the commands themselves are not compiled-in. This gives a notably
	faster read access to these linked variables.

2002-06-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: optimised algorithm for exception range
	lookup; part of [Patch 453709].

2002-06-10  Vince Darley  <vincentdarley@users.sourceforge.net>

	* unix/tclUnixFCmd.c: fixed [Bug #566669]
	* generic/tclIOUtil.c: improved and sped up handling of
	native paths (duplication and conversion to normalized paths),
	particularly on Windows.
	* modified part of above commit, due to problems on Linux. 
	Will re-examine bug report and evaluate more closely.

2002-06-07  Don Porter  <dgp@users.sourceforge.net>

	* tests/tcltest.test:  More corrections to test suite so that tests
	of failing [test]s don't show up themselves as failing tests.

2002-06-07  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
	* tests/proc-old.test: Improved stack trace for TCL_BREAK and
	TCL_CONTINUE returns from procs. Patch by Don Porter
	[Bug 536955]. 
	
	* generic/tclExecute.c:
	* tests/compile.test: made bytecodes check for a catch before
	  returning; the compiled [return] is otherwise non-catchable. 
	  [Bug 542588] reported by Andreas Kupries.

2002-04-15  Don Porter  <dgp@users.sourceforge.net>

	* tests/socket.test:  Increased timeout values so that tests have
	time to successfully complete even on slow/busy machines.  [Bug 523470]

	* doc/tcltest.n:







|







2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
	* tests/proc-old.test: Improved stack trace for TCL_BREAK and
	TCL_CONTINUE returns from procs. Patch by Don Porter
	[Bug 536955]. 
	
	* generic/tclExecute.c:
	* tests/compile.test: made bytecodes check for a catch before
	  returning; the compiled [return] is otherwise non-catchable. 
	  [Bug 542142] reported by Andreas Kupries.

2002-04-15  Don Porter  <dgp@users.sourceforge.net>

	* tests/socket.test:  Increased timeout values so that tests have
	time to successfully complete even on slow/busy machines.  [Bug 523470]

	* doc/tcltest.n:
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
	* unix/tclUnixPipe.c:
	* win/tclWin32Dll.c:
	* win/tclWinFCmd.c:
	* win/tclWinFile.c:
	* win/tclWinInit.c: Partial TIP 27 rollback.  Following routines
	restored to return (char *): Tcl_DStringAppend,
	Tcl_DStringAppendElement, Tcl_JoinPath, Tcl_TranslateFileName,
        Tcl_ExternalToUtfDString, Tcl_UtfToExternalDString,
	Tcl_UniCharToUtfDString, Tcl_GetCwd, Tcl_WinTCharToUtf.  Also
	restored Tcl_WinUtfToTChar to return (TCHAR *) and 
	Tcl_UtfToUniCharDString to return (Tcl_UniChar *).  Modified
	some callers.  This change recognizes that Tcl_DStrings are
	de-facto white-box objects.

	* generic/tclDecls.h:







|







2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
	* unix/tclUnixPipe.c:
	* win/tclWin32Dll.c:
	* win/tclWinFCmd.c:
	* win/tclWinFile.c:
	* win/tclWinInit.c: Partial TIP 27 rollback.  Following routines
	restored to return (char *): Tcl_DStringAppend,
	Tcl_DStringAppendElement, Tcl_JoinPath, Tcl_TranslateFileName,
	Tcl_ExternalToUtfDString, Tcl_UtfToExternalDString,
	Tcl_UniCharToUtfDString, Tcl_GetCwd, Tcl_WinTCharToUtf.  Also
	restored Tcl_WinUtfToTChar to return (TCHAR *) and 
	Tcl_UtfToUniCharDString to return (Tcl_UniChar *).  Modified
	some callers.  This change recognizes that Tcl_DStrings are
	de-facto white-box objects.

	* generic/tclDecls.h:
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
	* unix/tclUnixChan.c (FileOutputProc): Fixed [bug 465765] reported
	  by Dale Talcott <daletalcott@users.sourceforge.net>. Avoid
	  writing nothing into a file as STREAM based implementations will
	  consider this a EOF (if the file is a pipe). Not done in the
	  generic layer as this type of writing is actually useful to
	  check the state of a socket.

	* doc/open.n: Fixed [Bug 511540], added cross-reference to 'pid'
	  as the command to use to retrieve the pid of a command pipeline
	  created via 'open'.

2002-02-25  Daniel Steffen  <das@users.sourceforge.net>
 
        * unix/tclLoadDyld.c: updated to use Mac OS X 10.1 dyld APIs that     
        have more libdl-like semantics. (bug #514392)

2002-02-04  Jim Ingham   <jingham@apple.com>

	* Merge with the current TOT.
	
2002-02-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* doc/open.n: Fixed [Bug 511540], added cross-reference to 'pid'
	  as the command to use to retrieve the pid of a command pipeline
	  created via 'open'.

2002-02-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): handle quirky about case







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







3038
3039
3040
3041
3042
3043
3044















3045
3046
3047
3048
3049
3050
3051
	* unix/tclUnixChan.c (FileOutputProc): Fixed [bug 465765] reported
	  by Dale Talcott <daletalcott@users.sourceforge.net>. Avoid
	  writing nothing into a file as STREAM based implementations will
	  consider this a EOF (if the file is a pipe). Not done in the
	  generic layer as this type of writing is actually useful to
	  check the state of a socket.
















	* doc/open.n: Fixed [Bug 511540], added cross-reference to 'pid'
	  as the command to use to retrieve the pid of a command pipeline
	  created via 'open'.

2002-02-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): handle quirky about case
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
	* generic/tclDecls.h: 
	* generic/tclIntDecls.h: make genstubs

	* doc/ParseCmd.3 (Tcl_ParseVar):
	* generic/tcl.decls (Tcl_ParseVar):
	* generic/tclParse.c (Tcl_ParseVar):
	* generic/tclTest.c (TestparsevarObjCmd): Updated APIs in
        generic/tclParse.c according to the guidelines of TIP 27.  Updated
	callers.  [Patch 501046]
	* generic/tclDecls.h: make genstubs

	* generic/tcl.decls (Tcl_RecordAndEval):
	* generic/tclDecls.h: make genstubs
	* generic/tclHistory.c (Tcl_RecordAndEval): Updated APIs in
	generic/tclHistory.c according to the guidelines of TIP 27.







|







3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
	* generic/tclDecls.h: 
	* generic/tclIntDecls.h: make genstubs

	* doc/ParseCmd.3 (Tcl_ParseVar):
	* generic/tcl.decls (Tcl_ParseVar):
	* generic/tclParse.c (Tcl_ParseVar):
	* generic/tclTest.c (TestparsevarObjCmd): Updated APIs in
	generic/tclParse.c according to the guidelines of TIP 27.  Updated
	callers.  [Patch 501046]
	* generic/tclDecls.h: make genstubs

	* generic/tcl.decls (Tcl_RecordAndEval):
	* generic/tclDecls.h: make genstubs
	* generic/tclHistory.c (Tcl_RecordAndEval): Updated APIs in
	generic/tclHistory.c according to the guidelines of TIP 27.
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129

2002-01-15  Don Porter <dgp@users.sourceforge.net>

	* doc/SetErrno.3 (Tcl_ErrnoMsg): Corrected documentation for
	Tcl_ErrnoMsg; it takes an integer argument.  Thanks to Georgios
	Petasis.  [Bug 468183]

        * doc/AddErrInfo.3 (Tcl_PosixError):
        * doc/Eval.3 (Tcl_EvalFile):
        * doc/FileSystem.c (Tcl_FSOpenFileChannel,Tcl_FSOpenFileChannelProc):
        * doc/OpenFileChnl.3 (Tcl_OpenFileChannel):
        * doc/SetErrno.3 (Tcl_ErrnoId,Tcl_ErrnoMsg):
        * doc/Signal.3 (Tcl_SignalId,Tcl_SignalMsg):
        * generic/tcl.decls (Tcl_ErrnoId,TclErrnoMsg,Tcl_EvalFile,
	  Tcl_OpenFileChannel,Tcl_PosixError,Tcl_SignalId,Tcl_SignalMsg,
	  Tcl_FSOpenFileChannel):
	* generic/tcl.h (Tcl_FSOpenFileChannelProc):
	* generic/tclIO.c (FlushChannel):
	* generic/tclIOUtil.c (Tcl_OpenFileChannel,Tcl_EvalFile,TclGetOpenMode,
	  Tcl_PosixError,Tcl_FSOpenFileChannel):
	* generic/tclInt.decls (TclGetOpenMode):







|
|
|
|
|
|
|







3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574

2002-01-15  Don Porter <dgp@users.sourceforge.net>

	* doc/SetErrno.3 (Tcl_ErrnoMsg): Corrected documentation for
	Tcl_ErrnoMsg; it takes an integer argument.  Thanks to Georgios
	Petasis.  [Bug 468183]

	* doc/AddErrInfo.3 (Tcl_PosixError):
	* doc/Eval.3 (Tcl_EvalFile):
	* doc/FileSystem.c (Tcl_FSOpenFileChannel,Tcl_FSOpenFileChannelProc):
	* doc/OpenFileChnl.3 (Tcl_OpenFileChannel):
	* doc/SetErrno.3 (Tcl_ErrnoId,Tcl_ErrnoMsg):
	* doc/Signal.3 (Tcl_SignalId,Tcl_SignalMsg):
	* generic/tcl.decls (Tcl_ErrnoId,TclErrnoMsg,Tcl_EvalFile,
	  Tcl_OpenFileChannel,Tcl_PosixError,Tcl_SignalId,Tcl_SignalMsg,
	  Tcl_FSOpenFileChannel):
	* generic/tcl.h (Tcl_FSOpenFileChannelProc):
	* generic/tclIO.c (FlushChannel):
	* generic/tclIOUtil.c (Tcl_OpenFileChannel,Tcl_EvalFile,TclGetOpenMode,
	  Tcl_PosixError,Tcl_FSOpenFileChannel):
	* generic/tclInt.decls (TclGetOpenMode):
2373
2374
2375
2376
2377
2378
2379
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

	* tests/string.test (string-11.51):
	* generic/tclUtf.c (Tcl_UniCharCaseMatch):
	* generic/tclUtil.c (Tcl_StringCaseMatch): Fault with matching
	case-insensitive non-ASCII patterns containing upper case
	characters.  [Bug #233257]

2001-12-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/init.tcl: make sure env(COMSPEC) on Windows is executed
	with the right case, as it may otherwise fail inexplicably.

2001-12-28  Don Porter <dgp@users.sourceforge.net>

	* generic/tclCkalloc.c (MemoryCmd, TclFinalizeMemorySubsystem):
	Added the [memory onexit] command, intended to replace [checkmem].

	* doc/DumpActiveMemory.3: 
	* doc/memory.n: Updated documentation for [memory] and related
	matters.  [Bug 487677]

	* mac/tclMacBOAMain.c (Tcl_Main, CheckmemCmd): Removed all the
	machinery for the [checkmem] command that is completely duplicated
	by code in generic/tclCkalloc.c.

	* generic/tclBinary.c:
	* generic/tclListObj.c:
	* generic/tclObj.c:
	* generic/tclStringObj.c: Removed references to [checkmem] in
	comments, referencing [memory active] instead, since it is
	documented.

2001-12-28  Daniel Steffen <das@users.sourceforge.net>

	* mac/tclMacInit.c:
	* mac/tclMacTclCode.r: synced up tclInit features to unix/win:
	implemented TclSetPreInitScript support, use of existing tclInit 
	proc if defined, check of default encoding dir if set. Changed
	script library resource names to lowercase (i.e. same as
	corresponding files). Used Tcl_JoinPath instead of string append.
	Check that system encoding could be loaded before utf translating
	the LibraryPath.
	* mac/tclMacApplication.r:
	* mac/tclMacLibrary.r:
	* mac/tclMacOSA.r:
	* mac/tclMacResource.r: minor version resources cleanup

2001-12-21  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/tcl.m4 (SC_PATH_TCLCONFIG, SC_PATH_TKCONFIG):
	Search for config file using exec_prefix instead of
	prefix when no --with-tcl or --with-tk argument is used. [Bug 492418]

2001-12-21  Daniel Steffen <das@users.sourceforge.net>

	* unix/tcl.m4: fixed incorrect SHLIB_LD_LIBS
	setting for MacOSX / Darwin.
	* unix/configure: Regen.
	* unix/mkLinks.tcl: improved case-insensitive
	filesystem support.
	* unix/mkLinks: Regen.

2001-12-19  Don Porter <dgp@users.sourceforge.net>

	* unix/Makefile.in (dist): corrected use of eolFix.tcl on
	working files.  It should operate on distributed files.  [Bug 495120]

2001-12-19  David Gravereaux <davygrvy@pobox.com>

	* tools/tcl.wse.in: Fix for #495120.  tcl.wse.in was
	stored in cvs with improper <eol>.  This resulted in
	corrupted <eol> when checked-out on translating CVS
	clients such as windows (CRCRLF) and mac (CRCR).

2001-12-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure:
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Update
	SunOS 5.[0-6] target so that correct linker
	options are passed to gcc or ld. [Tk Bug 220863]

2001-12-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/README: Update to account for changes
	in the unix/dltest directory, the way autoconf
	is run, and the new "make shell" target.

2001-12-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Rename dltest to dlpkgs to
	fix problem where lib files were not getting
	built because dltest/ directory already existed.

2001-12-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinSerial.c (SerialCheckProc): corrected time
	calculations to be unsigned. (schroedter)

2001-12-18  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Define new dltest target that
	simply does a cd to dltest/ before running make.
	There is no need for the separate configure
	script that was previously being used.
	* unix/configure: Regen.
	* unix/configure.in: Subst into dltest/Makefile.
	* unix/dltest/Makefile.in: Define LIBS using
	DL_LIBS, LIBS, and MATH_LIBS variables instead
	of TCL_LIBS variable from tclConfig.sh.
	* unix/dltest/README: Update readme to account for new
	configure free implementation.
	* unix/dltest/configure: Removed.
	* unix/dltest/configure.in: Removed.

2001-12-18  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tcl.h (TCL_STUB_MAGIC): Added cast to force type to be
	an int and get rid of a persistent and pointless warning with
	SunPro compiler.

	* generic/tclCkalloc.c (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc): 
	* generic/tcl.decls (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc):
	Made the file parameters to these functions into CONST char *,
	like they always should have been to match the other Tcl*Db* API
	functions.

2001-12-17  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* Applied #219311 on behalf of Rolf Schroedter
	  <schroedter@users.sourceforge.net> to prevent fcopy on serial
	  ports from flooding the event queue.

2001-12-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/CrtInterp.3:
	* generic/tclBasic.c: docs and comments corrections [Bug 493412]
	Bug & patch by Don Porter.  

2001-12-14  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* win/tclWinNotify.c (Tcl_FinalizeNotifier): Stop Tcl on Windows
	from crashing when shutdown from a non-Tcl thread. Fixes Bug
	#217982 [orig. 5804] reported by Hugh Vu and Gene Leache.   I'm
	not convinced that the shutdown process is right even with this,
	but it was definitely wrong without...

2001-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* win/tclWinSock.c (TcpGetOptionProc): Fix for tcl bug item
	  #478565 reported by an unknown person. Bypasses all calls to
	  "gethostbyaddr" for address "0.0.0.0" to prevent delays on
	  Win/NT.

2001-12-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/Preserve.3: doc'd TCL_DYNAMIC use. [Patch #483989] (porter)

2001-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclIO.c (Tcl_GetsObj): Applied patch for bug #491341 as
	  provided by Don Porter <dgp@users.sourceforge.net>. Fixes the
	  assumption of having an empty Tcl_Obj to work with.

2001-12-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c:
	* generic/tclCompile.c:
	* generic/tclExecute.c: consistency patch, to make all
	  instructions that pop a variable number of Tcl_Obj's off the
	  execution stack take the number of popped objects as first
	  operand. Modified *only* the new instructions
	  INST_LIST_INDEX_MULTI and INST_LSET_FLAT, so this has no effect
	  on bytecodes generated up to tcl8.4a3 inclusive.

	* generic/tclExecute.c: fix debug messages in INST_LSET_LIST. 

	* generic/tclCompCmds.c (TclCompileLindexCmd):
	* generic/tclCompExpr.c (CompileMathFuncCall): removed the last
	  two overestimates of the necessary stack depth for bytecodes in
	  the fix of [Bug 483611].

2001-12-10  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* unix/tclUnixPipe.c (TclpCreateProcess): Applied Don Porter's
	  patch fixing bug #437489.

2001-12-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclEvent.c:
	* tests/event.test: fix background error reporting in the absence
	of a bgerror proc [Bug 219142].

2001-12-10  Don Porter <dgp@users.sourceforge.net>

	* doc/Access.3:
	* doc/CrtChannel.3:
	* doc/DString.3:
	* doc/ExprLong.3:
	* doc/FileSystem.3:
	* doc/GetStdChan.3:
	* doc/OpenFileChnl.3:
	* doc/StdChannels.3:
	* doc/TCL_MEM_DEBUG.3:
	* doc/Tcl_Main.3:
	* doc/Utf.3:
	* doc/file.n:
	* doc/tclsh.1:  Several typo and formatting corrections discovered
	during conversion to TMML.  Thanks to Joe English.  [Patch 490514]
	* unix/mkLinks: 'make mklinks'

2001-12-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c:
	* generic/tclCompExpr.c:
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclProc.c: fixed the calculation of the maximal stack
	depth required by bytecodes [Bug 483611].

2001-12-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: 
	* tests/trace.test: restored consistency in refCount accounting by
	array traces [Bug #4484339], submitted by Don Porter. 

2001-12-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/parseExpr.test, tests/for.test, tests/expr.test:
	* tests/expr-old.test, tests/compile.test, tests/compExpr.test
	* tests/compExpr-old.test: Kept up to date with syntax errors.
	* generic/tclParseExpr.c (ParsePrimaryExpr): Rewrote to give even
	better syntax errors in the fairly common case of an identifier
	without decorations by guessing based on the currently available
	functions.  Also made messages consistent between memdebug and
	ordinary builds.

2001-12-05  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: 
	* tests/trace.test: new algorithm for [array get], safe when there
	are traces that modify the array [Bug #449893]. 

2001-12-04  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/compExpr-old.test, tests/compExpr.test, tests/compile.test: 
	* tests/expr-old.test, tests/expr.test, tests/for.test: 
	* tests/while.test, tests/if.test: Rewrite to handle more specific
	syntax errors.
	* tests/parseExpr.test: Rewrite to get rid of dup test numbers and
	handle more specific syntax errors.
	* generic/tclParseExpr.c (LogSyntaxError): Added a detail message
	argument to help explain what the syntax error is.
	(Tcl_ParseExpr, ParseCondExpr, ParsePrimaryExpr): Added detail
	messages.
	(UNKNOWN_CHAR): New lexeme for characters that are always illegal
	in expressions outside strings.

2001-12-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/expr.n: Various documentation improvements in relation to
	the function calls.  Includes fix for Bug #487704 submitted by
	Devin Eyre.

2001-12-03  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc: Some install target bugs repaired along with
	$(TCLSTUBLIB) added to the dependencies rather than implicit through
	the dde and reg extensions which don't happen to always require it
	for some build types.

2001-11-30  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: Tcl_Preserve'ing VarTrace structures to avoid 
	memory corruption. Patch for [Bug: 484334] provided by Don Porter 

2001-11-29  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/namespace.test: modified namespace-41.2, added 41.3
	{knownbug} after discussion with Don Porter and Kevin Kenny.

2001-11-29  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/namespace.test: added namespace-41.2, a simpler test for
	[Bug: 231259]

2001-11-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclBinary.c (BINARY_SCAN_MAX_CACHE, Tcl_BinaryObjCmd,
	ScanNumber): Added caching scheme to reduce number of object
	allocations when doing scans of large repetitive binary strings.
	See comments in file for reasoning behind implementation.
	Suggested by Miguel Sofer in Patch #429916, but independently
	implemented.

2001-11-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/regsub.n, doc/regexp.n: Converted dangling references to
	METASYNTAX section into references to the re_syntax manual page.

2001-11-27  D. Richard Hipp   <drh@hwaci.com>

	* win/tclWinFCmd.c: Fix a coredump in the filename normalizer
	code for Win95/98.

2001-11-27  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc: Removed the Tk reference for the 'winhelp' target.
	Converge at install will need to be the solution for Tk and all other
	extensions.

2001-11-27  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdAH.test (cmdAH-24.2): Made test less sensitive to OS
	preemption, but perfection isn't practical [Bug 463189, reported
	by Don Porter.]

	* tests/switch.test (switch-9.*): Added tests to exercise more of
	the argument checking.  (switch-7.2,switch-7.3): Test changed
	behaviour slightly.
	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reworked argument parsing
	to be stricter about what it accepts.  This should make uses of
	the [switch] command be more maintainable.  [Bug 475397, reported
	by Don Porter.]

2001-11-26  Don Porter <dgp@users.sourceforge.net>

	* generic/tclIntPlatDecls.h: 'make genstubs' after changes
	in 2001-11-23 commit from Daniel Steffen.

2001-11-24  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Add comments to better describe
	TCL_EXE and when it should be available.
	* win/Makefile.in: Add TCL_EXE variable to be used
	by rules like `make genstubs`. Don't set TCL_LIBRARY
	before running `make genstubs` since we will be running
	with a tclsh from the PATH not the one we build.

2001-11-24  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Add comctl32.lib
	to wish link libs. This change was originally added
	to Tk on 2001-11-09 but was not committed to Tcl.

2001-11-23  Daniel Steffen <das@users.sourceforge.net>

	* unix/Makefile.in:
	* unix/configure.in:
	* unix/install-sh:
	* unix/mkLinks:
	* unix/mkLinks.tcl:
	* unix/tclLoadDyld.c:
	* unix/tclMtherr.c: Mac OSX support: build system, dynamic code loading
	and support for case-insensitive filesystems in mkLinks (patch #435258)

2001-11-23  Daniel Steffen <das@users.sourceforge.net>

	Up-port to 8.4 of mac code changes for 8.3.3 & various new
	changes for 8.4, some already backported to 8.3.4 (patch #435658)

	* generic/tclObj.c: added #include to fix missing prototype errors

	* generic/tcl.h: MAC_TCL: addition of ConditionalMacros.h and use of
	DLLIMPORT and DLLEXPORT like on other platforms.  ( => no longer need
	the .exp files and can remove use of #pragma export that never worked
	well)
	removed line continuation in #if clause as this breaks the mac
	resource compiler (note that *.r files include tcl.h)

	* mac/tclMacFile.c: fixed bug in permission checking code

	* mac/tclMacLoad.c: corrected utf8 handling, comparison of
	package names to code fragment names changed to only match on the
	length of package name, this allows for fragment names with version
	numbers appended

	* mac/tclMacInt.h:
	* generic/tclInt.h:
	* mac/tclMacTime.c:
	* generic/tclIOUtil.c: moved declaration of TclpGetGMTOffset()

	* mac/tclMacShLib.exp:
	* mac/tclMacOSA.exp:
	* mac/tclMacMSLPrefix.h: removed files

	* unix/Makefile.in: removed reference to .exp files

	* mac/MW_TclBuildLibHeader.h:
	* mac/MW_TclBuildLibHeader.pch:
	* mac/MW_TclHeaderCommon.h:
	* mac/MW_TclStaticHeader.h:
	* mac/MW_TclStaticHeader.pch: new precompiled header files

	* mac/MW_TclAppleScriptHeader.pch:
	* mac/MW_TclHeader.pch:
	* mac/MW_TclTestHeader.pch:
	* mac/tclMacCommonPch.h: revised precompiled header handling: now
	include a common header file 'MW_TclHeaderCommon.h' from all .pch
	files, the .pch files themselves now only setup #defines (e.g.
	BUILD_tcl, STATIC_BUILD, TCL_DEBUG, TCL_THREADS) like in makefiles on
	other platforms.

	* mac/tclMac.h:
	* mac/tclMacPort.h:
	* mac/tclMacInt.h: use of BUILD_tcl and TCL_STORAGE_CLASS like on other
	platforms, standardize #include'd files to what's done on other
	platforms, removed use of #pragma export.

	* mac/tcltkMacBuildSupport.sea.hqx: new archive of mac build support
	files & suggested build environment directory hierarchy: 
	'Building MacTclTk' & 'CW Pro6 changes' readme's.
	projects for MoreFiles 1.5.2 static & shared libraries.
	project & sources for 'pseudoCarbonSupport', see below.
	included XML versions of the projects for CW Pro5 or Pro7 users.

	* mac/tclMacProjects.sea.hqx: updated mac build project files:
	build support for CodeWarrior Pro6, UnivIntf 3.4 & shared runtime
	libraries: the MSL libraries and MoreFiles are no longer compiled into
	Tcl.shlb, all non-static binaries now use the Pro6 shared runtime
	libraries and MoreFiles.shlb.  These shlbs are merged into the standard
	Wish and TclShell, but 3rd party applications linking with Tcl.shlb or
	Tk.shlb need to setup access to them.  (see the "(sh-ppc)" targets
	for how to do this.)
	included XML versions of the projects for CW Pro5 or Pro7 users.
	use compat/strtod.c instead of MSL's strtod()
	use WASTE versions of MSL for tcl test target to avoid text buffer
	cutoff at 32k.
	Merging the full MSL.shlb and the other shlbs into Wish & TclShell
	makes them a bit larger than before, use unmerged binaries to avoid
	copying the shared code with every application, e.g. when deploying
	numerous Wish based droplets.
	Note that using CW Pro5 to compile extensions is in principle still
	possible, but need to link with Pro6 runtime libraries.
	Tclapplescript now loads and runs on CFM68k.
	Highly experimental "pseudoCarbon" support for Tcl only on OS 8/9:
	binaries in "Build:(Carbon):" link against CarbonLib instead of
	InterfaceLib, however the actual code has not been carbonized! i.e. it
	will not run on OSX and may not even run properly with CarbonLib. 
	This should in principle allow you to build & test OS9 CFM Carbon
	binaries that need to link with Tcl.shlb.  On OSX you can use the
	native Tcl.framework, but you have to build a MachO binary as there
	is no CFM glue lib for Tcl.framework.
	the library pseudoCarbonSupport.shlb manually loads the symbols
	from InterfaceLib that are not in CarbonLib but are needed by the
	uncarbonized code in Tcl.shlb and TclShell.

	* generic/tclMain.c: MAC_TCL: workaround for broken/non-standard isatty
	on MW Pro6, #include <unistd.h> instead of defining isatty

	* mac/tclMacPort.h: MW Pro6 changes for MSL fcntl.h, stat.h & isatty

	* mac/tclMacAppInit.c: add EXTERN to InstallConsole to enable DLL
	export via the TCL_STORAGE_CLASS mechanism.

	* mac/tclMacFCmd.c: fix for FSpDirectoryCopy API change

	* mac/tclMacLibrary.c: emit compile time error when
	TCL_REGISTER_LIBRARY and USE_TCL_STUBS are both defined at the same
	time in an extension, this use is not currently supported and will
	result in a crash when dynamically loading the extension.

	* mac/tclMacApplication.r:
	* mac/tclMacLibrary.r:
	* mac/tclMacOSA.r:
	* mac/tclMacResource.r: fixed obsolete copyrights/dates in version
	strings; updated version strings to standard usage; added support for
	'(Support Libraries)' subfolder for shared runtime libraries in
	unmerged binaries; commented out demo setting of "Tcl Environment
	Variables"; reorganized resources among these files to avoid 
	multiple copies in applications and shared libraries, the script
	libraries are now no longer duplicated in Tclsh but are only included 
	in the resources of Tcl.shlb.

	* mac/tclMacChan.c:
	* mac/tclMacSock.c: cast for *BlockMode

	* mac/tclMacUtil.c:
	* mac/tclMacMath.h: removed obsolete hypot() definition

	* generic/tclIntPlatDecls.h:
	* generic/tclInt.decls:
	* generic/tclStubInit.c:
	* mac/tclMacNotify.c:
	* mac/tclMacOSA.c:
	* mac/tclMacUtil.c:
	* generic/tclThreadTest.c: renamed routines conflicting with standard
	Apple or MoreFiles headers (at compile or link time):
	GetGlobalMouse         -> GetGlobalMouseTcl
    	FSpGetDirectoryID      -> FSpGetDirectoryIDTcl
    	FSpOpenResFileCompat   -> FSpOpenResFileCompatTcl
    	FSpCreateResFileCompat -> FSpCreateResFileCompatTcl
	NewThread              -> NewTestThread
	the renamed MoreFiles *Tcl routines are just wrappers calling into the
	MoreFiles DLL.

	* mac/tclMacCommonPch.h:
	* mac/tclMacThrd.c:
	* mac/tclMacPanic.c: removed OLDROUTINENAMES define, renamed obsolete
	apple API names to modern equivalents; UH3.4 support: added #include
	<ControlDefinitions.h>, updated New*Proc() calls to New*UPP().

	* mac/tclMacUnix.c: added missing (Tcl_Obj ***) cast to
	Tcl_ListObjGetElements call

	* mac/tclMacAlloc.c: modernized TclpSysAlloc() to use temporary
	memory instead of system heap memory when available (MacOS
	>= 7.5 and possibly earlier, use of system heap has been
	discouraged for a long time and has many disadvantages, e.g. memory
	isn't paged out, and errors can very easily bring the system down);
	fixed crashing bug in TclpSysRealloc() and CleanUpExitProc() where
	memory was being accessed after having been deallocated; fixed
	memory leak in (de)allocation code (for every block ever allocated
	with TclpSysAlloc, a Ptr was leaked), if temporary memory is
	available, don't track allocated memory, instead use
	RecoverHandle() to get Handle from Ptr, otherwise use doubly linked
	list to correctly track memory and free all allocated memory; added
	new option for ConfigureMemory: MEMORY_DONT_USE_TEMPMEM, disables
	use of temporary memory even when it would be available, only
	necessary when writing e.g. a driver (using tcl??); increased
	fraction of application heap reserved for OS routines to 512K

	* compat/strftime.c: 
	* mac/tclMacTime.c:
	* mac/tclMacPort.h:
	* generic/tclInt.decls: 
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: timezone support for mac via 
	TclpGetTZName() like on windows, using an inverse timezone table
	adapted from tclDate.c to map gmtoffset in seconds gotten from
	the MacOS APIs to a  timezone string, as there is no good way to get
	this info from MacOS. I had to make up some unusual timezones and
	arbitrarily decide on the most standard of the multiple choices
	available for every timezone.

	* generic/tclExecute.c: workaround for a MSL bug/misfeature: for
	very small floats, MSL can return errno ERANGE but a
	non-zero value ( < LDBL_MIN however)
	
	* mac/tclMacAppInit.c: support for WASTE text library using
	temporary memory, setting has no effect if WASTE is not used.
	
	* mac/tclMacPanic.c: removed duplicate code from generic/tclPanic.c
	and added that file to projects instead.

	* tests/all.tcl: set tcltest::singleProcess 1 as multiple processes
	are not available on the mac.
	
	* tests/cmdAH.test: access time not available on the mac, skip the 
	atime touch test
	
	* tests/appendComp.test:
	* tests/cmdMZ.test:
	* tests/compile.test:
	* tests/exec.test:
	* tests/fileName.test:
	* tests/lset.test:
	* tests/namespace.test:
	* tests/tcltest.test: added missing cleanups/tests/catches that
	caused tests to fail on the mac.

	* doc/tclvars.n: doc bug, env(PWD) should be env(HOME) [Bug 463834]
	
2001-11-21  Don Porter	<dgp@users.sourceforge.net>

	* tests/trace.test (trace-8.8): Corrected test for Bug 219393.

	* generic/tclBasic.c (Tcl_DeleteCommandFromToken,CallCommandTraces):
	* generic/tclCmdMZ>c (Tcl_UntraceCommand):  Added Tcl_Preserve and
	Tcl_Release calls to prevent deletion of CommandTrace structures
	until all callers are done using them, preventing memory corruption.
	[Bug 453805]

2001-11-20  Kevin B. Kenny  <kennykb@users.sourceforge.net>

	* doc/GetTime.3 (Tcl_GetTime):
	* generic/tcl.decls (Tcl_GetTime):
	* generic/tclClock.c (Tcl_ClockObjCmd):
	* generic/tclCompile.c (TclCleanupByteCode, TclInitByteCodeObj):
	* generic/tclCmdMZ.c (Tcl_TimeObjCmd):
	* generic/tclUtil.c (TclpGetTime):
	* generic/tclTest.c (GetTimesCmd):
	* generic/tclTimer.c (Tcl_CreateTimerHandler, TimerSetupProc,
	TimerCheckProc, TimerHandlerEventProc):
	* mac/tclMacNotify.c (Tcl_SetTimer):
	* mac/tclMacShLib.exp (Tcl_GetTime):
	* mac/tclMacTime.c (Tcl_GetTime):
	* unix/tclUnixChan.c (TclUnixWaitForFile):
	* unix/tclUnixEvent.c (Tcl_Sleep):
	* unix/tclUnixThrd.c (Tcl_ConditionWait):
	* unix/tclUnixTime.c (Tcl_GetTime):
	* win/tclWinNotify.c (Tcl_Sleep):
	* win/tclWinTest.c (TestwinclockCmd):
	* win/tclWinTime.c (TclpGetSeconds, TclpGetClicks, Tcl_GetTime):
	Changed all uses of TclpGetTime to Tcl_GetTime.  Added Tcl_GetTime
	to the Stubs table and the library documentation.  Added a
	TclpGetTime in tclUtil.c for backward compatibility of
	extensions. [Patch #483500, TIP#73]

	* generic/tclCmdMZ.c (Tcl_TimeObjCmd): Corrected an error in the
	[time] command that caused incorrect results to be returned if the
	total duration of all iterations exceeded 2**31 microseconds.
	[Bug #478847]

	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclStubInit.h: Reran 'make genstubs'
	
2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c
	* generic/tclCompile.h: 
	* generic/tclExecute.c: moving all code relative to bytecodes from
	tclBasic.c to tclExecute.c - the functions RecordTracebackInfo and
	Tcl_ExprObj went to tclExecute.c, and new interface function was
	defined (TclCompEvalObj).
	The final objective of this sequence of moves is to provide a
	clean, clear-cut interface between Tcl's core and the
	compiler/engine subsystem.  

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c
	* generic/tclCompile.h: 
	* generic/tclExecute.c: factoring out of common code in tclBasic.c
	(new function TclInterpReady defined: it resets the interp's
	result, then checks that it hasn't been deleted and that the
	nesting level is acceptable). Passed the responsibility of calling
	it to the *callers* of TclEvalObjvInternal.

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c
	* generic/tclExecute.c: a better variant of the previous-to-last
	commit (restoring numLevels computations). The managing of the
	levels now has to be done by the *callers* of TclEvalObjvInternal  

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: missing variable declaration under
	TCL_COMPILE_DEBUG. 

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c:
	* generic/tclProc.c: restoring the computations of iPtr->numLevels
	to the original logic (previous to buggy modifs on 2001-11-16).

2001-11-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* tools/eolFix.tcl (new-file):
	* unix/Makefile.in: added EOL correction for Windows bat files to
	dist target. [Bug #219409] (davygrvy)

	* unix/tclUnixInit.c (TclpSetInitialEncodings): update of patch
	from 2001-11-16 that uses the old Tcl encoding check mechanism as
	a fallback to the original.  Also added a TCL_DEFAULT_ENCODING
	#define (defaults to iso8859-1).  Tcl will first try setlocale and
	nl_langinfo, and if that fails, guess based on certain LANG|LC_*
	env vars. [Patch #418645]

2001-11-19  David Gravereaux <davygrvy@pobox.com>

	* win/buildall.vc.bat:  Added useful comments.

2001-11-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/compile.test: added a test for bug [Bug 483309]

2001-11-19  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFile.c:
	* win/tclWinFCmd.c:
	* win/tclWin32Dll.c:
	* doc/file.n:
	* tests/winFCmd.test: improved speed of file normalization
	for Win95/98, and clarified docs on differences in file
	normalization between NT/2000 and the older operating systems.
	Added test to ensure normalization is correct.
	
2001-11-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c:
	* generic/tclParse.c: Code reorganisation. Moved all evaluation
	functions from tclParse.c to tclBasic.c, so that now tclParse.c
	deals exclusively with parsing and all evaluations are done by
	code in tclBasic.c. The functions moved are: TclEvalObjvInternal,
	Tcl_EvalObjv, Tcl_LogCommandInfo, Tcl_EvalTokensStandard,
	Tcl_EvalTokens, Tcl_EvalEx, Tcl_Eval, Tcl_EvalObj and
	Tcl_GlobalEvalObj. 

2001-11-19  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/trace.test (trace-8.8): Added adapted version of Bug
	#219393 as new test; the test won't reliably show up the old
	problem unless it is being run under something like Purify, but
	something is better than nothing...

	* generic/tclVar.c (Tcl_TraceVar2, Tcl_UntraceVar2): Added missing
	mask bits for trace result type and a check for a nonsense flag
	combination.
	* generic/tclCmdMZ.c (TraceVarProc): Added missing test for NULL
	when deleting a trace that doesn't cause an error.

	* doc/TraceVar.3: Added documentation for change due to TIP#68.

	* generic/tclCmdMZ.c (TraceVarInfo): Removed problematic errMsg
	field from structure.
	(TraceVarProc): Removed references to errMsg field and changed
	handling of errors so that they returned a Tcl_Obj* containing the
	error string.  This minimizes the number of calls to the memory
	management subsystem.
	(TclTraceCommandObjCmd, TraceCommandProc): Removed references to
	errMsg field which was never used in command traces in any case.
	(Tcl_TraceObjCmd, TclTraceVariableObjCmd): Removed references to
	errMsg field and made variable traces register with
	TCL_TRACE_RESULT_OBJECT bit set.

	* generic/tcl.h (TCL_TRACE_RESULT_DYNAMIC,TCL_TRACE_RESULT_OBJECT): 
	New constants to define how to handle the strings returned from
	trace callbacks [TIP#68]
	* generic/tclVar.c (CallTraces, Tcl_GetVar2Ex, TclGetIndexedScalar,
	TclGetElementOfIndexedArray, Tcl_SetVar2Ex, TclSetIndexedScalar,
	TclSetElementOfIndexedArray, Tcl_UnsetVar2, Tcl_ArrayObjCmd,
	TclDeleteVars, TclDeleteCompiledLocalVars, DeleteArray,
	TclVarTraceExists): Support for those new trace flags.

2001-11-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c: patch for [Bug 483309] (petasis).

2001-11-16  Kevin B. Kenny  <kennykb@users.sourceforge.net>

	* generic/tclListObj.c: removed a C++-style comment that
	  was inadvertently left in the source code.

2001-11-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/interp.test: 
	* generic/tclInterp.c (SlaveObjCmd): Corrected argument checking
	for '$interp alias|aliases|issafe'. [Patch #479560] (thoyts, hobbs)

	* unix/tclUnixInit.c: added HAVE_LANGINFO code block.
	* unix/configure: regened
	* unix/configure.in: added SC_ENABLE_LANGINFO call
	* unix/tcl.m4: made SHLIB_LD_LIBS='${LIBS}' for FreeBSD* (meyer)
	Added modified version of Wagner patch to make use of nl_langinfo
	where possible to determine Unix platform encoding, instead of the
	inflexible built-in system.  This is used by default when
	possible, and can be disabled with --enable-langinfo=no.
	[Patch #418645] (hobbs, wagner)

2001-11-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclObj.c: moved Tcl_GetCommandFromObj and all defining
	code for tclCmdNameType objects to tclObj.c (from tclExecute.c). 
	This code has nothing to do with bytecodes.

2001-11-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclParse.c:
	* generic/tclProc.c:
	* tests/stack.test: consolidation of duplicated code (in
	TclExecuteByteCode and EvalObjv); renaming of EvalObjv to
	TclEvalObjv as it is not static anymore; restored consistency of
	level counts between compiled and directly evaled code.
	[Bug 480896]

2001-11-12  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc:
	* win/rules.vc:  Small bug fixes.

	* win/README: added some docs pointing to the docs in makefile.vc
	for it's use.

2001-10-17  Kevin B. Kenny  <kennykb@users.sourceforge.net>

	* doc/lappend.n:
	* doc/lindex.n:
	* doc/linsert.n:
	* doc/list.n:
	* doc/llength.n:
	* doc/lrange.n:
	* doc/lsearch.n:
	* doc/lset.n (new-file):
	* doc/lsort.n:
	* generic/tclBasic.c (builtInCmds, Tcl_EvalObjEx):
	* generic/tclCmdIL.c (Tcl_LindexObjCmd, Tcl_LindexList):
	(Tcl_LindexFlat, Tcl_LsetObjCmd):
	* generic/tclCompCmds.c (Tcl_CompileLindexCmd, Tcl_CompileLsetCmd):
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c (TclExecuteByteCode):
	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclIntDecls.h:
	* generic/tclListObj.c (TclLsetList, TclLsetFlat, TclSetListElement):
	* generic/tclObj.c (TclInitObjSubsystem):
	* generic/tclStubInit.c:
	* generic/tclTestObj.c (TestobjCmd):
	* generic/tclUtil.c (TclGetIntForIndex, SetEndOffsetFromAny):
	* generic/tclVar.c (Tcl_LappendObjCmd):
	* tests/lindex.test:
	* tests/lset.test (new-file):
	* tests/lsetComp.test (new-file):
	* tests/obj.test:
	* tests/string.test:
	* tests/stringComp.test:
	Reference implementation of TIP's #22, #33 and #45.  Adds the
	ability of the [lindex] command to have multiple index arguments,
	and adds the [lset] command.  Both commands are byte-code compiled.
	[Patch #471874] (work by Kenny, commited by Hobbs)

2001-11-12  David Gravereaux <davygrvy@pobox.com>

	* win/buildall.vc.bat(new):
	* win/makefile.vc:  Small fix with deriving the "OriginalFilename"
	string in the .rc scripts.  Added a quick batchfile for building
	the entire thing.

2001-11-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/FileSystem.3:
	* doc/file.n:
	* doc/tcltest.n: converted use of \' to more reasonable format.

2001-11-10  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in: Add "make gdb" target. This target
	can run tclsh inside either gdb or insight.

2001-11-10  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc:  Added a check to make sure one runs the makefile
	from the /win directory only.

	* win/mkd.bat:
	* win/rmd.bat:  Changes from Llyod Lim for better stability.
	[Patch #456759]

2001-11-09  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc:
	* win/tcl.dsp:  winhelp target fixes for non-NT systems.  It
	seems NMAKE under these remembers changed directories during
	commands.   A new tcltest feature from Peter Spjuth 
	<peter.spjuth@space.se> to specify a pattern file from the
	commandline and redirecting output to a file when not under
	NT with it's scrollback console.  Then it replays it, piped
	through more.  Added 2 new static "configurations" to tcl.dsp.
	I could keep adding more, but I think we should leave it up to
	the user for customizing it.

	Sticky-points left:  'profile' option.

2001-11-09  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/FileSystem.3:
	* doc/StdChannels.3:
	* doc/file.n:
	* doc/tcltest.n:
	* tools/man2help.tcl: 
	* tools/man2help2.tcl: fixed winhelp generation problems
	[Patch #480268]

	* unix/configure:
	* unix/tcl.m4: added -lc to AIX libs, fixed path to ldAix

2001-11-09  Don Porter	<dgp@users.sourceforge.net>

	* tests/var.test:
	* generic/tclVar.c: Corrected bug in [global] when dealing
	with variable names matching :*.  [Bug 480176]

2001-11-08  Mo DeJong  <mdejong@users.sourceforge.net>

	Fixup stack size under OSF1. [Tcl patch 474790]

	* unix/configure: Regen.
	* unix/tcl.m4: Add HAVE_PTHREAD_ATTR_SETSTACKSIZE define
	to EXTRA_CFLAGS to adjust initial stack size.

2001-11-08  Mo DeJong  <mdejong@users.sourceforge.net>

	Enable thread support under FreeBSD. [Tcl bug 473708]

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_ENABLE_THREADS): Check for pthread functions
	in libc_r and enable thread support if found.
	* unix/dltest/Makefile.in: Set SHLIB_LD_LIBS and use it in
	the Makefile to properly link a shared library.

2001-11-08  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* unix/dltest/Makefile.in:
	Avoid adding libc to the LIBS variable since it
	is not needed when linking with CC. If required
	when linking with LD it should be done on a case
	by case basis in tcl.m4.

2001-11-08  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc:
	* win/makefile.vc:  Fixed install target to adjust for the
	different build types.  Added a 'linkexten' option to link the
	win extensions inside the shell when built static.  Placed
	win/tclAppInit.c patch in SF patch DB for approval. 'profile'
	option not hooked in yet.  Everything else know is done.

	* win/tcl.dsp(new):
	* win/tcl.dsw(new):  Simple MsDev stub project files that calls
	makefile.vc.  Will help run Tcl in the debugger easier without
	confusing MsDev for where the .pdb files are.

2001-11-07  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in:
	Print a message indicating that the user should
	run "make genstubs" when the generated tclStubInit.c
	file is out of date. We can't regenerate automatically
	since there may be no tclsh on the system and that
	would cause bootstrap problems. [Tcl bug 465874]

2001-11-07  Mo DeJong  <mdejong@users.sourceforge.net>

	Define TCL_INCLUDE_SPEC in tclConfig.sh. It should be
	included by extensions that need to find Tcl include
	headers in the install location. The user can override
	the include install dir with --includedir so we need
	to record this information for extensions. [Tcl bug 421835]
	
	* unix/configure: Regen.
	* unix/configure.in: Define TCL_INCLUDE_SPEC.
	* unix/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.
	* win/configure: Regen.
	* win/configure.in: Define TCL_INCLUDE_SPEC.
	* win/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.

2001-11-07  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc:
	* win/makefile.vc: Dropped the NOMSVCRT macro and put it on the
	option list instead.  It makes more sense to me this way as
	NOMSVCRT=0 would only be the valid setting.  Fixed the dde and reg
	extension for building static.  Improved, but not perfected, the
	winhelp target.

2001-11-07  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/README: Change minimum VC++ version to 5.X since
	4.X is known not to work.
	Indicate that Mingw is required and building with Cygwin
	gcc is not supported. Include instructions that indicate
	how to install Mingw and what URLs folks should use to
	download the supported version of Mingw.
	* win/configure: Regen.
	* win/configure.in: Error out if user tries to compile the
	Windows version of Tcl with Cygwin gcc. Users should compile
	with Mingw gcc instead.

2001-11-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclIO.c (ReadChars): Fixed bug #478856 reported by
	  Stuart Cassoff <stwo@users.sourceforge.net>. The bug caused loss
	  of fileevents when [read]ing less data from the channel than
	  buffered. Due to an empty input buffer the flag
	  CHANNEL_NEED_MORE_DATA was set but never reset, causing the I/O
	  system to wait for more data instead of using a timer to
	  synthesize fileevents and to flush the pending data out of the
	  buffers.

2001-11-06  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc (new):
	* win/makefile.vc:  Complete over/under rewrite to support numerous
	build options all from the commandline itself without needing to
	edit the makefile.  Now requires vcvars32.bat to be run prior to
	running nmake for bootstraping the environment.  Fully doc'd usage
	for it is in makefile.vc.  Commentary welcome.  Sticky points left
	are:

	1) winhelp target shows errors in the converting script.
	2) .rc scripts aren't getting the right #defines to build the correct
	   "OriginalFilename" strings. (have patch, won't commit yet)
	3) Naming convention with suffixes describing the buildtype are 'tsdx'
	   which will need public acceptance. ie. tclsh84tsx.exe is a (t)
	   threaded shell (s) statically linked to the core and (x) uses
	   msvcrt instead of libcmt.

2001-11-04  Vince Darley  <vincentdarley@users.sourceforge.net>

	* library/init.tcl: made filesystem fallback proc
	::tcl::CopyDirectory more robust to vagaries of non-native
	filesystems.
	
2001-11-02  Vince Darley  <vincentdarley@users.sourceforge.net>

	* doc/file.n:
	* generic/tclIOUtil.c: updated documentation and comments
	to clarify behaviour of 'file copy' wrt soft links.
	
2001-10-29  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFile.c: fix to '-types {f r}' bug in
	TclpMatchInDirectory (which could cause a UMR, as well as
	returning wrong results).  Also improved API for 'stat'
	to resolve [Bug#219258].
	* win/tclWin32Dll.c
	* win/tclWinInt.h: addition of improved stat API to internal 
	lookup table.
	* tests/fileName.test: two new tests for the above bug.
	* generic/tclIOUtil.c: some cleanup of comments and #ifdefs
	
2001-10-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tclUnixFile.c (TclpMatchInDirectory): Argument to access()
	was entryPtr->d_name instead of nativeEntry which failed when
	trying to check access for files in other than the current
	directory. [Bug 475941, reported by Georgios Petasis]

2001-10-25  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tclUnixChan.c: Added stateUpdated member to struct TtyState.
	(TtyCloseProc,TtySetOptionProc,TtyInit): Use stateUpdated member
	of TtyState to decide whether it is necessary to reset a serial
	port when Tcl closes it.  Blindly resetting can cause Tcl to be
	sent an unexpected SIGTSTP when it is executing in the background
	[Bug 471374, reported by Chris Nelson]

2001-10-22  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* doc/ObjectType.3: Minor documentation fix, reported by David
	  N. Welton <davidw@users.sourceforge.net> directly to me.

2001-10-22  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFCmd.c: fix to stop test suite from hanging process
	under some versions of WinNT. [Bug #466102] (Kevin Kenny)
	
2001-10-18  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/clock.test (clock-8.1): 
	* generic/tclDate.c (RelativeMonth): 
	* generic/tclGetDate.y (RelativeMonth): corrected off-by-one-day
	error in clock scan with relative months and years during swing
	hours. [Bug #413397, Patch #414024] (lavana)

2001-10-18  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c: fix to bug in Tcl_FSChdir shown up
	by recent tclkit builds.

2001-10-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/tclUnixPipe.c (PipeInputProc, PipeOutputProc): do immediate
	retry when error is returned with errno == EINTR.
	[Bug #415131] (leger)

2001-10-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/tclLoadAout.c (TclGuessPackageName): removed unused vars
	and fixed warnings. [Bug #446622] (lim)

2001-10-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclProc.c: changing a memcmp to strncmp to avoid a memory
	error detected by purify (thanks Jeff); modify style to agrre with
	the style guide. 
	
2001-10-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclInt.decls (TclExpandCodeArray,TclGetInstructionTable):
	  Added to internal stubs table. Tclcompiler (Tclpro project)
	  needs them if used as loadable package under Windows. Changed
	  signatures. We don't want to describe compiler internal
	  structures in "tclInt.h".

	* generic/tclCompile.h: S.a. Removed function declarations.
	* generic/tclCompile.c: S.a. Adapted to changed signatures.

2001-10-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/configure: 
	* unix/configure.in: 
	* win/configure: 
	* win/configure.in: 
	* win/tcl.m4: reworked to be a little cleaner in comparison to
	each other, and to AC_SUBST even empty vars for win/tclConfig.sh

	* generic/tclFileName.c: minor code cleanup

	* generic/tcl.h: moved #define of WIN32 to tcl.h where __WIN32__
	is defined and added #ifndef check.

	* doc/open.n: moved all fconfigure option docs to fconfigure.n
	* doc/fconfigure.n: added serial config options

	* win/tclWinChan.c:
	* win/tclWinPort.h:
	* win/tclWinSerial.c: added TIP #35 Windows enhancements for
	serial configuration. [Patch #438509] (schroedter)

2001-10-15  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclFCmd.c: fix to memory leak in TclFileDeleteCmd on
	certain error conditions.
	* doc/FileSystem.3: fix to typo.
	
2001-10-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/encoding/ebcdic.enc:
	* tools/encoding/ebcdic.txt: EBCDIC charset mapping.
	[Patch #219323] (nijtmans)

	* library/encoding/tis-620.enc:
	* tools/encoding/tis-620.txt: TIS-620 charset mapping.
	[Patch #467423] (poonlap)

	* tests/http.test: added removeFile for outdata

	* tests/ioCmd.test: added catch around file removal, as Windows
	file locking throws errors.

	* tests/socket.test (socket-7.2): corrected to work on Win2K.

2001-10-12  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* tests/compile.test: new tests for [Bug 467523]; they are only
	effective if TCL_MEM_DEBUG was set during compilation.

2001-10-11  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclLiteral.c (TclReleaseLiteral): insured that
	self-referential bytecodes are properly cleaned up on interpreter
	deletion [Bug 467523] (Ronnie Brunner)

2001-10-10  David Gravereaux  <davygrvy@pobox.com>

	* win/tclWinPort.h:  #include <winsock2.h> needed to get moved
	to after #include <windows.h> or wierd misunderstandings took
	place when -D_WIN32_WINNT=0x0400 is set for outside code that
	requires knowledge of Tcl innards.  General header macro magic
	applied liberally...

2001-10-10  Don Porter	<dgp@users.sourceforge.net>

	* tests/unixInit.test:	Corrected restore of ::env(LANG).

2001-10-09  Jeff Hobbs	<jeffh@ActiveState.com>

	* generic/tclFileName.c (Tcl_SplitPath): corrected mem leak
	intro'd with VFS code where the result obj from Tcl_FSSplitPath
	was not getting freed.

2001-10-09  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclLiteral.c: (TclReleaseLiteral) reverted previous
	patch for [Bug 467523] - cure is worse than the illness.

2001-10-05  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclLiteral.c: (TclReleaseLiteral) insured that
	self-referential bytecodes are properly cleaned up on interpreter
	deletion [Bug 467523] (Ronnie Brunner)

2001-10-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* tools/configure:
	* tools/configure.in: noted 8.4 as default Tcl version

	* library/encoding/cp936.enc:
	* library/encoding/cp949.enc:
	* library/encoding/cp950.enc:
	* library/encoding/iso8859-16.enc:
	* library/encoding/macCroatian.enc:
	* library/encoding/macCyrillic.enc:
	* library/encoding/macGreek.enc:
	* library/encoding/macIceland.enc:
	* library/encoding/macRoman.enc:
	* library/encoding/macTurkish.enc:
	* tools/encoding/cp1250.txt:
	* tools/encoding/cp1251.txt:
	* tools/encoding/cp1252.txt:
	* tools/encoding/cp1253.txt:
	* tools/encoding/cp1254.txt:
	* tools/encoding/cp1255.txt:
	* tools/encoding/cp1256.txt:
	* tools/encoding/cp1257.txt:
	* tools/encoding/cp1258.txt:
	* tools/encoding/cp874.txt:
	* tools/encoding/cp932.txt:
	* tools/encoding/cp936.txt:
	* tools/encoding/cp949.txt:
	* tools/encoding/cp950.txt:
	* tools/encoding/iso8859-1.txt:
	* tools/encoding/iso8859-10.txt:
	* tools/encoding/iso8859-13.txt:
	* tools/encoding/iso8859-14.txt:
	* tools/encoding/iso8859-15.txt:
	* tools/encoding/iso8859-16.txt:
	* tools/encoding/iso8859-2.txt:
	* tools/encoding/iso8859-3.txt:
	* tools/encoding/iso8859-4.txt:
	* tools/encoding/iso8859-5.txt:
	* tools/encoding/iso8859-6.txt:
	* tools/encoding/iso8859-7.txt:
	* tools/encoding/iso8859-8.txt:
	* tools/encoding/iso8859-9.txt:
	* tools/encoding/koi8-r.txt:
	* tools/encoding/macCentEuro.txt:
	* tools/encoding/macCroatian.txt:
	* tools/encoding/macCyrillic.txt:
	* tools/encoding/macGreek.txt:
	* tools/encoding/macIceland.txt:
	* tools/encoding/macRoman.txt:
	* tools/encoding/macTurkish.txt:
	Updated encodings with latest mappings from www.unicode.org.  This
	did not include some Mac encodings that have special multi-unichar
	translations now (like symbols, dingbats and japanese).  Also does
	not include big5, gb or euc* as those have different formats in
	the latest Unicode version that need new conversion tools.  Not
	all related .enc files changed as some had been updates separately.

2001-10-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclEvent.c (Tcl_FinalizeThread): moved freeing of
	tclLibraryPath to before the thread exit handlers are called.
	Slight modification to change on 2001-09-24.

2001-10-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/configure: regen'ed
	* win/tcl.m4:
	* win/makefile.vc: added Win64 SDK RC1 compilation support
	* win/Makefile.in: added $(LDFLAGS_CONSOLE) to TCLSH, TCLTEST and
	PIPE_DLL_FILE targets to get the link flags

	* win/tclWinInit.c: minor 64bit casts

2001-10-01  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCmdIL.c:
	* generic/tclCmdMZ.c:
	* generic/tclParseExpr.c: removed unnecessary inclusion of
	tclCompile.h and made a small modification in (InfoBodyCmd) to
	improve the isolation of the compiler/engine subsystem.

2001-09-29  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c:
	* doc/FileSystem.3: corrected and clarified documentation
	for 'Tcl_FSListVolumes(Proc)'.  No code changes.
	
2001-09-28  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/FindExec.3: added a comment not to change the working
	directory before calling Tcl_GetNameOfExecutable [Bug 219215] 

2001-09-28  Kevin Kenny   <kennykb@users.sourceforge.net>

	* generic/tclIO.c: added two more '(ClientData)' casts
	on calls to Tcl_Preserve and Tcl_Release -- ones that
	Vince apparently missed.
	
2001-09-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/lsort.n: Improved doc...
	* generic/tclCmdIL.c (Tcl_LsortObjCmd, SortCompare): Made
	offset-from-end indexing work, and factored out some "magic
	numbers" for easier understanding.  [Bug #465674]
	* tests/cmdIL.test (cmdIL-1.26): Added test for offset-from-end
	indexing for lsort.

2001-09-28  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFCmd.c:
	* unix/tclUnixFCmd.c: fix to performance issue reported
	by jcw in which 'access("")' is called unnecessarily when
	normalizing any absolute path.
	* generic/tclIO.c: added '(ClientData)' cast to calls to
	Tcl_(Preserve|Release) newly introduced, fixing compile
	error on Windows.
	
2001-09-27  Don Porter  <dgp@users.sourceforge.net>

	* doc/FileSystem.3 (Tcl_FSLoadFile):
	* generic/tcl.decls (Tcl_FSLoadFile):
	* generic/tcl.h (Tcl_FSLoadFileProc):
	* generic/tclInt.h (TclpLoadFile):
	* generic/tclIOUtil.c (Tcl_FSLoadFile):
	* generic/tclLoadNone.c (TclpLoadFile):
	* generic/tclTest.c (TestReportLoadFile):
	* library/ldAout.tcl:
	* mac/tclMacLoad.c (TclpLoadFile):
	* unix/tclLoadAix.c (TclpLoadFile):
	* unix/tclLoadAout.c (TclpLoadFile):
	* unix/tclLoadDl.c (TclpLoadFile):
	* unix/tclLoadDld.c (TclpLoadFile):
	* unix/tclLoadDyld.c (TclpLoadFile):
	* unix/tclLoadNext.c (TclpLoadFile):
	* unix/tclLoadOSF.c (TclpLoadFile):
	* unix/tclLoadShl.c (TclpLoadFile):
	* win/tclWinLoad.c (TclpLoadFile):
	* win/tclWinFCmd.c (DoRemoveJustDirectory):  More CONST poisoning
	fixes from the 2001-09-24 TIP 27 changes.  CONST-ified
	Tcl_FSLoadFile and TclpLoadFile.  Report and patch from Kevin
	Kenny. [Bug 465833]

	* generic/tclIO.c (ChannelTimerProc):  Added Tcl_Preserve()
	and Tcl_Release() to fix segfault introduced by the 2001-09-26
	changes.  [Bug 465494]

	* doc/TCL_MEM_DEBUG.3:  Updated out-of-date reference to
	#define GUARD_SIZE.

	* doc/UpVar.3 (Tcl_UpVar,Tcl_UpVar2):
	* generic/tcl.decls (Tcl_UpVar,Tcl_UpVar2):
	* generic/tclInt.decls (TclFindProc,TclGetFrame):
	* generic/tclInt.h (TclFindProc,TclGetFrame,TclLookupVar,
	  TclPrecTraceProc,TclProcInterpProc}):
	* generic/tclProc.c (TclGetFrame,TclFindProc):
	* generic/tclVar.c (Tcl_UpVar,Tcl_UpVar2,MakeUpvar):  Updated APIs in
	generic/tclProc.c and generic/tclVar.c according to the guidelines
	of TIP 27.  [Patch 465442]

	* generic/tclDecls.h:
	* generic/tclIntDecls.h: make genstubs

2001-09-26  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* doc/fileevent.n: Accepted [Patch #465279] adding an example to
	  the fileevent manpage. Minor modifications to get a better
	  formatting. Report and patch by David N. Welton
	  <davidw@users.sourceforge.net>.

	* The changes below fix [Bug #462317] where Expect tried to read
	  more than was in the buffers and then blocked in the OS call as
	  its pty channel driver provides no blockmodeproc through which
	  the OS could be notified of blocking-behaviour. Because of this
	  the general I/O core has to take more care than usual to
	  preserve the semantics of non-blocking channels.

	  The problem was reported by "Kevin O'Gorman"
	  <kevin@kosmanor.com>.

	* generic/tclIO.c (Tcl_ReadRaw): Do not read from the driver if
	  the channel is non-blocking and the fileevent causing the read
	  was generated by a timer. We do not know if there is data
	  available from the OS. Instead of going to the OS for more and
	  potentially blocking we simply signal EWOULDBLOCK to the higher
	  levels to cause the system to wait for true fileevents.
	  (GetInput): Same as before.
	  (ChannelTimerProc): Added set and clear of CHANNEL_TIMER_FEV.

	* generic/tclIO.h (CHANNEL_TIMER_FEV): New flag for channels. Is
	  set if a fileevent was generated by a timer, the channel is not
	  blocking and the driver did not provide a blockmodeproc. In that
	  case the I/O core has to be especially careful about going to
	  the driver for more data.

2001-09-26  Don Porter  <dgp@users.sourceforge.net>

	* doc/SplitPath.3 (Tcl_GetPathType):
	* generic/tcl.decls (Tcl_GetPathType):
	* generic/tclFileName.c (Tcl_GetPathType):
	* win/tclWinFile.c (TclpMatchInDirectory, NativeStat):  Vince
	Darley reports the 2001-09-24 TIP 27 changes left the win
	directory CONST poisoned.  These changes should fix that.

	* generic/tclDecls.h: make genstubs

2001-09-25  Don Porter  <dgp@users.sourceforge.net>

	* doc/GetInt.3:
	* generic/tclInt.h (TclGetLong deleted):
	* generic/tcl.decls:
	* generic/tclInt.decls:
	* generic/tclGet.c:  Updated APIs in generic/tclGet.c
	according to the guidelines of TIP 27.  [Patch 464674]

	* generic/tclDecls.h: 
	* generic/tclIntDecls.h: make genstubs

2001-09-25  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: removed comments referring to unused flag
	TCL_PARSE_PART1. 
	
2001-09-24  Don Porter  <dgp@users.sourceforge.net>

	* doc/Concat.3:
	* doc/DString.3:
	* doc/SplitList.3:
	* generic/tclInt.h (TclCheckBadOctal):
	* generic/tcl.decls:
	* generic/tclInt.decls:
	* generic/tclEncoding.c (OpenEncodingFile):
	* generic/tclMain.c (Tcl_Main):
	* generic/tclUtil.c:
	* unix/tclLoadDl.c (TclpLoadFile):  Updated APIs in 
	generic/tclUtil.c according to the guidelines of TIP 27.
	[Patch 464553]

	* generic/tclDecls.h: 
	* generic/tclIntDecls.h: make genstubs

2001-09-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* The change below fixes [Bug #464380]. The bug was reported by
	  Ronnie Brunner <rbrunner@users.sourceforge.net>. He also
	  provided the patch.
	
	* generic/tclEvent.c (Tcl_Finalize): Moved release of
	  'tclLibraryPath' to Tcl_FinalizeThread.
	  (Tcl_FinalizeThread): See above, new place for release of
	  'tclLibraryPath'.

2001-09-24  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tools/encoding/cp1252.txt: File was missing part of the encoding
	  [euro, ZCaron and zcaron].

	* doc/OpenFileChnl.3: Add docs for Tcl_OutputBuffered; remove some
	  old changebars.

2001-09-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclExecute.c (TclExecuteByteCode): corrected
	  INST_STR_CMP else case for strings to pass true utf char length
	  to Tcl_UtfNCmp.

2001-09-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinInit.c: added extra processor definitions. (mstacy)

	* win/tclWinSock.c (SocketThread): corrected pointer cast for _WIN64.

	* win/tclWinNotify.c: removed unnecessary winsock include (it is
	  already in from tclWinPort.h).

	* win/tclWinPort.h: changed winsock.h include to winsock2.h.
	  Reverses change from 2000-11-16, but is necessary for WIN64.
	  Extensions should comply with defined OS words, or use #ifndef.

2001-09-20  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/socket.test: removed dependence on being run from same dir
	  as remote.tcl, which only now needs to be in the same dir as
	  this file.  [Bug #219326]

2001-09-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclTest.c (TestcmdtokenCmd): corrected pointer
	  storage/retrieval for 64bit machines.

	* generic/tclCmdAH.c (Tcl_FormatObjCmd):
	* generic/tclScan.c (Tcl_ScanObjCmd): corrected handling of format
	and scan on 64-bit machines. [Bug #412696] (rmax)

	* unix/configure: regen'ed
	* unix/tcl.m4: added --enable-64bit support for HP-11 with the
	64-bit kernel.

	* tests/basic.test:
	* tests/cmdInfo.test: improved skip reporting of missing commands

	* tests/winFCmd.test: simplified error check for winFCmd-7.9

	* tests/winPipe.test: removed obsolete cat16 tests

	* generic/tclExecute.c (TclExecuteByteCode): fixed invalid usage
	of valuePtr in TRACE_WITH_OBJ in INST_EVAL_STK case. [Bug #462594]
	Changed INST_STR_CMP instruction to promote to Unicode strings
	only when one of the strings is already of Unicode type.

	* generic/tclExecute.c (TclExecuteByteCode):
	* generic/tclCompile.c (instructionTable):
	* generic/tclCompCmds.c (TclCompileStringCmd): INST_STR_MATCH -
	Updated to Int1 instruction type and added special case to use
	INST_STR_EQ instead when no glob chars are specified in a static
	string.

	* tests/{for.test,foreach.test,if.test,while.test}:
	* generic/tclCompCmds.c (TclCompileForCmd, TclCompileForeachCmd,
	TclCompileIfCmd, TclCompileWhileCmd): Corrected the overaggressive
	compiling of loop bodies enclosed in ""s.  [Bug #219166] (msofer)

2001-09-19  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclExecute.c: insured that execution stack errors are
	also detected at abnormal returns.

2001-09-19  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/socket.n: Added documentation to mention what happens when a
	server socket is created with port=0.  Removed an old change bar,
	and no new change bar because Tcl has always behaved this way as
	it is really a poorly-documented standards-defined OS feature.

	* tests/util.test (util-8.1): Test derived from code to detect the
	problem, but the test always works in the C locale, so beware if
	you are maintaining the code.
	* generic/tclUtil.c (TclNeedSpace): Rewrote to be UTF-8 aware.
	[Bug 411825, but not that patch which would have added extra
	spaces if there was a real non-ASCII space involved. ]

2001-09-18 Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclIOCmd.c (Tcl_PutsObjCmd): Rewritten to have saner and
	  faster argument handling.  Fixes bug #123552. Patch provided by
	  Donal K. Fellows <fellowsd@cs.man.ac.uk>: #402564.

2001-09-18  Don Porter  <dgp@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): On Linux, disable inlining when
	one of the compat/*.c routines is to be linked in. [Patch 440891]

2001-09-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tcl.h: removed forced #define USE_TCLALLOC 1 for
	Windows.  This means the native system allocator will be used by
	default.  This should be binary and source compatible with
	extensions, as Tcl_Alloc is a properly stubbed function.

2001-09-17  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclExecute.c: corrected small bug in [Patch 456668] -
	the varFramePtr was not restored in one possible exit.

2001-09-17  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* doc/tclvars.n:
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclProc.c: disabled all compile and execution tracing
	functionality in standard builds; TCL_COMPILE_DEBUG is now
	necessary to enable it. [Bug 451858]

2001-09-14  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* doc/gets.n: 
	* doc/read.n: 
	* doc/puts.n: 
	* doc/flush.n: 
	* doc/fconfigure.n: 
	* doc/flush.n: 
	* doc/eof.n: 
	* doc/seek.n: 
	* doc/tell.n: 
	* doc/close.n: 
	* doc/fileevent.n: Added references to the Tcl standard
	  channels. Item [219250], reported by David LeBlanc
	  <whisper@oz.net>. Thanks to Christopher Nelson
	  <chris@pinebush.com> for doing editorial work.

2001-09-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* win/Makefile.in:
	* win/configure.in:
	* win/makefile.bc:
	* win/makefile.vc:
	* library/dde/pkgIndex.tcl: Fixed version numbers from bogus tcl
	  versions to independent versions for dde and registry packages.

2001-09-13  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/regexp.test (regexp-20.1):
	* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): had to adjust fix from
	2001-08-06 to actually duplicate the objects in certain cases.
	This is really a place where feather would have been essential.
	[Bug #461322]

	* generic/tclUtf.c (Tcl_UtfPrev): corrected to return the proper
	location when the middle of a UTF-8 byte was passed in.
	[Tk Bug #450504]

	* ChangeLog.1999:
	* ChangeLog: broke changes from 199x into ChangeLog.1999 to reduce
	  size of the main ChangeLog.

2001-09-13  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* tests/ioCmd.test: Changed the computation of the result for
	  iocmd-8.1[123] so that the tests work for single- and
	  multi-process execution of the testsuite. Depending on the
	  choice of the user stdout is a tty or not and thus reports
	  different channel options. Fixes [460993] reported by Don
	  Porter.

2001-09-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/ParseCmd.3:  
	* generic/tcl.decls:
	* generic/tclCmdMZ.c (Tcl_SubstObjCmd):
	* generic/tclDecls.h:
	* generic/tclParse.c:
	* generic/tclStubInit.c:
	* tests/parse.test: Deprecate the use of Tcl_EvalTokens, replaced
	by the new Tcl_EvalTokensStandard. The new function performs the
	same duties but adheres to the standard return convention for Tcl
	evaluations; the deprecated function could only return TCL_OK or
	TCL_ERROR, which caused [Bug 219384] and [Bug 455151].
	This patch implements [TIP 56].
	
2001-09-12  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4: Invert the logic that checks for $GCC.
	Instead of checking for "$GCC" = "no" we check for
	"$GCC" != "yes" or simply swap the true and false
	blocks of code in an if statement. That way if
	GCC is set to "" everything will still work. [Bug 460991]

2001-09-12  Don Porter <msofer@users.sourceforge.net>

	* tests/appendComp.test:
	* tests/lsearch.test:
	* tests/namespace.test:
	* tests/rename.test:
	* tests/split.test:  Corrected tests to better isolate tests in
	one file from influencing tests in other files.  [Bug 460591]

2001-09-12  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tcl.decls: reserved stub #481 for the implementation of
	[TIP 56]

2001-09-11  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* doc/OpenFileChnl.3: Added documentation for Tcl_WriteRaw and
	  Tcl_ReadRaw [#414929].
	
	* doc/CrtChannel.3: Added documentation for Tcl_ChannelBuffered
	  and Tcl_GetTopChannel [#414929].

	* The changes below are a fix for [219253].

	* tests/socket.test: Removed _most_ instances of hardwired port
	  numbers for listening sockets. Remaining are the ports in all
	  tests with constraint 'doTestsWithRemoteServer'. These seem to
	  be designed for a more controlled environment and are usually
	  skipped when running the testsuite.

	* tests/io.test: Removed all instances of hardwired port numbers
	  for listening sockets.

2001-09-10  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclEvent.c (TclInExit): Corrected handling of tsd in
	late stages of finalization.  [Bug #419449] (darley)

	* tests/stack.test:
	* generic/tclInterp.c (AliasObjCmd): Check the numLevels to ensure
	that we aren't hitting some alias loop condition.  [Bug #443184]

2001-09-10  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Don't include . characters
	in the Tcl library name when building on FreeBSD 3.X and later
	systems. [Patch 450725]

2001-09-10  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* doc/tclsh.1:
	* doc/Tcl_Main.3: 
	* doc/CrtChannel.3: 
	* doc/OpenFileChnl.3: 
	* doc/GetStdChan.3: Enhanced the manpages with cross-references to
	  the new manpage and more explanations how these functions deal
	  with the standard channels in various situations.

	* doc/StdChannels.3: New manpage describing handling of the
	  standard channels by the Tcl library [402725].

2001-09-10  Don Porter <dgp@users.sourceforge.net>

	* unix/mkLinks (Tcl_FSLink): Updated to reflect 2001-08-23
	file system changes.

	* unix/tclLoadShl.c:  Added #include of tclInt.h; access to Tcl
	internals, notably TclpUnloadFile(), is required.  Thanks to
	Bob Techentin for report and patch.  [Bug 459305]

	* generic/tclInitScript.h (initScript):
	* win/tclWinInit.c (TCL_REGISTRY_KEY, TclpSetVariables):  Removed
	vestiges of Tcl's old initialization from registry variables.
	[Bug 455645]

2001-09-10  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclInt.decls: Also added 'TclWinFlushDirtyChannels' to
	  the internal platform specific stub table.

	* win/tclWinFile.c (TclpObjStat): Now added the call to
	  'TclWinFlushDirtyChannels' to this function. I don't know where
	  my head was last thursday (2001-09-06), but the call was
	  actually added to 'TclpObjChdir', i.e. the implementation of
	  [cd]. Corrected this now. Thanks to Vince Darley for spotting
	  this.

2001-09-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclProc.c:
	* tests/proc.test: made [proc] bytecompile a no-op for procs
	defined with _args_ as single argument and an empty body.
	[FQ 451441] 
	
2001-09-09  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in: Use () around variable name
	instead of {}. Use TCLTEST variable directly
	instead of depending on the tcltest alias.

2001-09-09  David Gravereaux <davygrvy@pobox.com>

	* generic/tcl.h:
	* generic/tclPlatDecls.h:  Reminder from David Cuthbert <dacut@kanga.org>
	that I hadn't finished the Borland compatibility stuff.
	[Patch: 436116]

2001-09-09  Mo DeJong  <mdejong@users.sourceforge.net>

	* tests/cmdAH.test: Modify cmdAH-20.5 and cmdAH-24.8
	to display the file atime or mtime results if
	the test fails.

2001-09-08  David Gravereaux <davygrvy@pobox.com>

	* win/mkd.bat:
	* win/rmd.bat: made these text files, text files again.
	[Patch: 451333]

2001-09-08  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/mkd.bat:
	* win/rmd.bat:
	Apply binary property (cvs admin -kb) to files and convert
	to CRLF linefeed format to fix the VC++ build. [Bug #219409]

2001-09-08 Vince Darley <vincentdarley@users.sourceforge.net>

	* generic/tclInt.h: 
	* generic/tclFCmd.c:
	* doc/FileSystem.3:
	* generic/tclIOUtil.c: removed Tcl_FSCopyFile fallback
	to channel copying, since the channels will not have
	access to interpreters and the channel copying currently
	requires an interp.  Code which required cross-platform
	copies always has interpreters, so that solves the problem.
	Fixes bug in TclKit.
	
2001-09-07  David Gravereaux <davygrvy@pobox.com>

	* win/tcl.m4: Added -link50compat option so a VC6 linker makes
	a VC5 (pre sp3) compatible import library.
	[Bug: 219257]

2001-09-07  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/tclWinThrd.c (TclpThreadExit): Cast status argument to
	_endthreadex to unsigned instead of DWORD to match the Win32
	function prototype.

2001-09-06  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* All the changes below serve to fix bug [219148] which reports a
	  80x performance hit for file I/O on Win* systems. On my system
	  it was closer to a 120x hit. Problem report by Uwe Traum <no
	  email address available>.

	  The fix goes like this: The obstacle is 'FlushFileBuffers',
	  executed whenever Tcl writes data to the OS, as Tcl has to wait
	  for the disk to complete I/O, and disks are slow. We remove that
	  obstacle. This opens another problem, [file size] reports back
	  wrong numbers. So for [file size] we add the call back in. As
	  optimization we keep track of the channels which were written to
	  and flush only these.

	* win/tclWinFile.c (TclpObjStat): Added a call to
	  'TclWinFlushDirtyChannels'. This ensures that [file size] and
	  related commands report the correct size of a file even if Tcl
	  has recently written to it. Unixoid OS's always report the
	  correct size even for files with pending data, but Win*
	  syssystem don't. They only report what is actually on disk.

	* win/tclWinInt.h: Added declaration of
	  'TclWinFlushDirtyChannels', making it available to other parts
	  of the tcl core.

	* win/tclWinChan.c (TclWinFlushDirtyChannels): New, internal,
	  procedure. Goes through the list of open file channels and
	  forces the OS to flush its file buffers for all which were
	  written to since the last call of this function. This is an
	  expensive operation as Tcl has to wait for the OS to complete
	  actual writes to the disk.

	  (FileInfo): Added dirty flag required by the procedure above.

	  (FileOutputProc): Removed flushing of file buffers, setting the
	  dirty flag instead. This means that the previously incurred
	  delays do not happen anymore.

	  (TclWinOpenFileChannel): Added initialization of 'dirty' flag.

2001-09-06  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/http.n: noted -binary, charset and coding state keys.
	* tests/http.test:
	* library/http/pkgIndex.tcl:
	* library/http/http.tcl (geturl): correctly get charset parameter
	and convert text according to specified encoding (if known).  RFC
	iso8859-1 is used by default.  Also recognize Content-encoding to
	see if we should do binary translation.  Added a CYA -binary
	switch for the cases that were missed. [Bug #219211 #219399]

	* tests/ioUtil.test: changed to make better use of constraints and
	remove knownBug constraints that weren't valid.

2001-09-06  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-3.2): Updated test to support
	  newer HP-UX releases that properly report euc-jp as the system
	  encoding for Japanese.  Bug report and patch verification by Bob
	  Techentin.  [Bug 453883]

	* doc/http.n:
	* library/http/*.tcl:
	* tools/tcl.wse.in:
	* tools/tclmin.wse:
	* unix/Makefile.in:
	* win/{Mm}akefile.*:  Updated http package to version 2.4,
	reflecting the new features just added.

2001-09-06 Vince Darley <vincentdarley@users.sourceforge.net>

	* generic/tclTest.c: tests of old-fs hooks no longer cause problems
	in threaded builds.  Also removed unused unload proc.
	* generic/tcl.decls:
	* generic/tclIOUtilc: added Tcl_FSMountsChanged so that a vfs
	can inform the filesystem that the filesystem epoch must be
	changed (since cached filesystems may now be incorrect).  Fixes
	problem running tclvfs extension.
	* library/tcltest/tcltest.tcl: if tests aren't in a native
	filesystem, then don't use pipes to run them. [Bug 458741]
	
2001-09-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tcl.decls (479 generic): 
	* generic/tclIO.c (Tcl_Seek,Tcl_Tell,Tcl_OutputBuffered): Added
	public function to return the size of the output buffer and
	reworked other channel functions to use this shared functionality
	and that of Tcl_InputBuffered() too. [TIP#49, Rolf Schroedter]

2001-09-05  David Gravereaux <davygrvy@pobox.com>

	* generic/tclPlatDecls.h:  Another small trim finalizing Borland
	support.

	* win/tclWinPipe.c:
	* win/tclWinPort.h:  More Borland compatibility fixes.  Changed
	EDQUOT #define from 49 to 69.  Borland had a clash as it was already
	using this number.  Upon advice from Helmut Giese, EDQUOT has been
	found in other header files #defined as 69.
	[Patch: 436116]

	* win/.cvsignore:  A few more glob patterns added.

	* win/makefile.bc (new):  Borland lives once more! rejoice..
	* generic/tclAlloc.c: Small Borland compatibility fix.
	* win/tclWinTime.c:  More Borland compatibility fixes.
	[Patch: 436116]

2001-09-05 Vince Darley <vincentdarley@users.sourceforge.net>

	* tests/winFCmd.test: made notWin2000 constraint false if not
	running on Windows at all.
	
2001-09-04  David Gravereaux <davygrvy@pobox.com>

	* win/tclWinThrd.c:  Revisited _beginthreadex() stuff.  Instead
	of assuming a c-runtime implimentation of _beginthreadex normal,
	I reversed the logic to not assume, and use when is by explicitly
	needing to add runtimes that support it such as Borland.

	* generic/tcl.h:
	* generic/tclPlatDecls.h:  Borland compatibility change so
	ClientData was properly typed as a void* and TCHAR would not be
	defined twice.

	* generic/tcl.h:  Removed a small mistake from before.  Changes to
	the EXTERN macro for proper Borland compatibility will have to see
	a TIP.  What's this with the MS compiler:

		__declspec(dllexport) int func (int a, int b);

	will have to be this with Borland:

		int __cdecl __export func (int a, int b);

	The order of the attribute needs to be after the return type.

2001-09-04  Don Porter  <dgp@users.sourceforge.net>

	* compat/strtod.c (strtod):  Fixed failure to handle expressions
	like 3eq2 and failure to set errno on overflow.  [Bug 440894]

2001-09-04  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclProc.c:
	* tests/proc.test: made [proc] check that formal args have
	simple names [Bug 458548] 

2001-09-04 Vince Darley <vincentdarley@users.sourceforge.net>

	Minor bug fixes in filesystem, plus small vfs changes as a 
	result of enabling the test filesystem to work properly.
	* tests/fileName.test: ensure new test cleans up after itself
	* doc/filename.n: 
	* generic/tclFileName.c: improved Mac path handling and document
	why [Bug: 421842] on Windows handling of UNC paths is not valid.
	Documentation and code now much clearer on what is and is not a 
	UNC path.
	* doc/FileSystem.3:
	* unix/tclUnixPipe.c:
	* generic/tclFCmd.c:
	* generic/tclIOUtil.c: fixed error message, fixed [Bug: 453512]
	about dangerous use of tmpnam, replaced with mkstemp.  
	Documented all the changes.
	* generic/tclTest.c: made test vfs fully functional as a 
	'reporting filesystem'.
	* generic/tcl.stubs:
	* generic/tcl.h:
	* generic/tclInt.h: 
	* generic/tclIOUtil.c:
	* doc/file.n:
	* various platform-specific 'TclpLoadFile': fixed comments about 
	unload behaviour, and completed objectification of loading.
	Required change to Tcl_Filesystem lookup table, so incompatible
	with 8.4a3, but not older versions of Tcl.  The change also
	allows 'link' and 'reporting' filesystems to function correctly
	when loading files.  Implementation of 'file delete -force'
	copes with case where cwd is inside the directory.  Moved
	overlooked Tcl_FSGetPathType from internal to external API.
	Made sure filesystems which are registered and then unregistered
	are only freed when all references to them are gone.
	Documented changes.
	* unix/tclUnixFCmd.c: when deleting directories recursively,
	make sure permissions are ok.  Together with the above, this
	fixes [Bug: 219139]
	* tests/winFCmd.test: differentiated test results for win2k 
	versus not.  This fixes [Bug: 219239]
	* tests/fCmd.test: added tests for 'file delete -force' where
	the cwd is inside, and when permissions are inadequate.
	
2001-09-04  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.c: fixed incorrect operands for INST_LIST
	[Bug: 458241] (David Cuthbert, dacut@users.sourceforge.net)

2001-09-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclExecute.c (TclExecuteByteCode): fixed missing comma
	in debug macro.

2001-09-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/ExprLongObj.3: Fixed error in documentation of argument type
	to Tcl_ExprObj [Bug: 457435]

2001-09-02  David Gravereaux <davygrvy@pobox.com>

	* win/tclWinThrd.c:  Portability fix for Cygwin who's c-runtime,
	not surprisingly, doesn't have the MSVCRT specific _beginthreadex /
	_endthreadex pair.  This might have to be revisited for proper
	Borland, lcc32, Watcom and other support as well.
	[Patch: 444255]

	* win/tclWinThrd.c:  Moved FinalizeConditionEvent() proto to within
	the main #ifdef TCL_THREADS block to avoid mingw warning about it
	being there but unused.

	* win/makefile.vc:  Added -Zl (zee el) to tclStubLib.c compile line
	to make sure the tclstub84.lib static library is built without
	requiring a specific C-runtime library at link-time for the end-use
	developer.  It has been noted on c.l.t that this trips many first
	time users trying to make extensions.
	[Patch: 403533]

2001-08-31  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclInt.h: added TclCompileListCmd header
	* generic/tclBasic.c: added TclCompileListCmd compile proc
	* generic/tclCompCmds.c (TclCompileListCmd): function to compile
	the 'list' command at parse time.
	* generic/tclExecute.c (TclExecuteByteCode): definition of
	INST_LIST bytecode.

	* doc/StringObj.3: added words of warning to use Tcl_ResetResult
	with the Tcl_Append* functions.

	* tests/compile.test: added compile-11.* interp result checks
	* generic/tclUtil.c (TclGetIntForIndex): added Tcl_ResetResult
	before Tcl_AppendStringsToObj to prevent shared object crash when
	called from bcc instruction.  The Tcl_Append* calls that append to
	the result object that are invoked by bcc insts must remember to
	call Tcl_ResetResult because the bcc doesn't do this for us.
	[Bug #456892]

2001-08-30  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclIndexObj.c: fixed some casting problems that upset
	Crays. [Bug #419528] (andreasen)

2001-08-30  Don Porter  <dgp@users.sourceforge.net>

	* generic/tcl.h: Silence warning from Sun compiler. [Bug 454374]

2001-08-30  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: allow cached fully-qualified command names
	to be usable from different namespaces within the same interpreter
	without forcing a new lookup. This speeds up scripts that pass
	command names in variables ("this" in some OO packages).
	[Patch 456668]. 

2001-08-30 Vince Darley <vincentdarley@users.sourceforge.net>

	Further fs updates.  After examining the most common Tcl
	extensions (TclX, BLT, Tk, TclPro, Mktclapp), it has been
	determined that only TclpGetCwd and the Access/Stat/Open
	insert/delete hooks of the internal fs functions are ever used.
	The remaining functions from Tcl's internal interfaces have
	therefore been removed, since Tcl now exports a more suitable
	public API (Tcl_FS...)
	
	* generic/tclInt.stubs:
	* generic/tclInt.h: updated for removed internal functions.
	Some new internal functions have been put in tclInt.h (and
	not exported in the stub table because good public equivalents
	exist).
	* generic/tclTest.c: some test functions used the internal private 
	APIs.  These tests have been retained, but modified to use 
	public APIs.  Also objectified the internal filesystem tests.
	* win/tclWinFile.c: removed TclpStat, TclpAccess and refactored
	code to use NativeAccess, NativeStat.  This should speed up
	stat, access and glob commands.
	* win/tclWinFCmd.c: removed all TclpCopy/Rename/Delete 
	File/Directory string-based procedures which aren't used any more.
	Improved efficiency of some other procedures. Ensure that filename
	conversions with a NULL interp do not crash Tcl.
	* mac/tclMacFCmd.c: wrapped long lines and cleaned up
	TclpObjNormalizePath, removed all TclpCopy/Rename/Delete 
	File/Directory string-based procedures which aren't used any more.
	* mac/tclMacFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
	etc.
	* unix/tclUnixFCmd.c: removed use of TclpAccess, removed all
	TclpCopy/Rename/Delete File/Directory string-based procedures which
	aren't used any more.
	* unix/tclUnixFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
	etc.
	* tcl(Unix|Mac|Win)Chan.c: objectified TclpOpenFileChannel.
	* various 'load' implementations all objectified.
	* generic/tclFileName.c: removed redundant code.
	* generic/tclIOUtil.c: removed TclStat, TclAccess, TclpListVolumes.
	Fix to MatchInDirectory at the root of a volume.  Also improved
	some documentation, and improved default path joining behaviour
	for virtual filesystems, especially regarding '~'.
	* tests/fileName.test: added tests to check for bugs fixed above.
	* doc/FileName.3: improved documentation
	
2001-08-30  David Gravereaux <davygrvy@pobox.com>

	* generic/tclAsync.c:
	* generic/tclEvent.c:
	* generic/tclInt.h: Improper cleanup of asyncMutex in tclAsync.c
	repaired.  TclFinalizeSynchronization() was trying to remove a
	registered mutex that was dumped earlier when the TSD it was stored
	in was cleared. This was only surfacing on *nix.  Windows was being
	masked by mutexes not actually being returned to the system!  That
	was repaired in a previous patch.  Needed to add a private
	TclFinalizeAsync() to tclAsync.c and called from Tcl_FinalizeThread().
	Pheww..  Is this done yet?
	[Bug: 414419] requested by Rob Ratcliff <rrr6399@futuretek.com>

2001-08-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCompCmds.c (TclPushVarName): noted 'static' defn.
	[Bug #453872]

2001-08-26  Don Porter <dgp@users.sourceforge.net>

	* library/auto.tcl (tcl_findLibrary):
	* tests/unixInit.test (unixInit-2.{1,9}):
	* unix/tclUnixInit.c (TclpInitLibraryPath):
	* win/tclWinInit.c (TclpInitLibraryPath):  Corrected 
	inconsistency between  the search path for script libraries and
	the directory name $DISTNAME into which distributions built
	by 'make test' unpack.  [Bug 455642]

2001-08-24  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/stringComp.test: added string-1.3
	* generic/tclCompCmds.c (TclCompileStringCmd): changed to return
	TCL_OUT_LINE_COMPILE instead of TCL_ERROR when compiling and an
	unknown string method is called.  This is necessary as the string
	command may be never called, or not until 'string' is redefined.

2001-08-24 Vince Darley <vincentdarley@users.sourceforge.net>

	* doc/glob.n: documented windows-style path issue with glob.
	[Bug: 219392]
	* doc/filename.n: documented windows path/file length limitation.
	[Bug: 454597]

2001-08-24  Don Porter <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-2.9): Corrected expected result
	to match Tcl's quirky construction of its init library path.

2001-08-23  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* win/tclWinPipe.c (BuildCommandLine): Fixed tcl Bug
	  [432499]. Part of the code used the non-absolute path to the
	  executable to determine quoting. This failed if the absolute
	  path contained spaces, but the application name itself not. This
	  bug caused no trouble on Win NT 5, but does for other variants
	  in the Win* family. Report and fix due to Ken Poole
	  <kenpoole@users.sourceforge.net>.

2001-08-23  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/configure:
	* unix/tcl.m4: added QNX-6 build support. [Bug #219410] (loverso)

	* unix/tclUnixFCmd.c:
	* generic/tclIOUtil.c:
	* generic/tclFileName.c: corrected minor compiler warnings.

2001-08-23 Vince Darley <vincentdarley@users.sourceforge.net>

	Variety of small filesystem and vfs issues fixed or improved.
	The new fs code allows many new opportunities for efficiency
	improvements through the objectified API. The main changes
	integrated here are such efficiency improvements.  Some
	limitations of the original implementation have also now been
	lifted.  Meanwhile a variety of fs bugs (some old, some new)
	have also been fixed.
	
	* generic/tclFileName.c: Made Tcl_FSSplitPath more efficient, 
	and removed some static string-based procedures which are no 
	longer used.  Much more objectification.  Tcl_FSJoinPath
	is now very efficient and more aware of virtual filesystems.
	Clarified where the Mac-specific code attempts to interpret
	Unix-style paths.  Modified TclDoGlob to use lstat not
	access to fix [Bug: 434876, L. Virden]
	* tcl(Win|Unix|Mac)FCmd.c:
	* tcl(Win|Unix|Mac)File.c: replaced TclpListVolumes with
	TclpObjListVolumes with different signature, updated code due
	to more efficient signature of Tcl_FSGetTranslatedPath.  Used
	cached native paths where possible to improve efficiency --
	this was completed on MacOS, but on Unix and Win the traversal
	functions make the task much more complex, so there are still
	some improvements possible there.  Removed unused 
	TclpNormalizePath which had been left in tclWinFCmd.c.
	Objectified all 'file attributes' functions.  Fixed the new
	[Bug:451571, Bruce Stephens] which is most obvious on Unix, 
	but could occur on MacOS or Windows.  This bug actually existed
	in Tcl 8.3.x but was only made obvious by the recent filesystem
	overhaul when the code was exercised more heavily.  
	* tests/fileName.test: Three new tests to exercise the above bug,
	and make sure it is fixed correctly.
	* unix/tclUnixFile.c: avoid panic in glob when a link
	doesn't point anywhere.  It would probably be good to define
	exactly what Tcl should do in circumstances like these, and
	make sure mac/win/unix all behave accordingly. [Bug: 417111, 
	Hemang Lavana]. Also fixed misleading/obsolete comment in the code.
	* generic/tcl.stubs: changed signature of Tcl_FSGetTranslatedPath
	and added Tcl_FSGetTranslatedStringPath.
	These changes allow further optimisations in the FS code.
	* generic/tcl.h: changed signature of Tcl_FSListVolumes so that 
	it doesn't require a Tcl interpreter plus result.  Renamed 
	Tcl_FSReadLink to Tcl_FSLink with additional argument so
	we can support making links in the future. [Patch: 450340]
	* generic/tclInt.h:
	added declaration for TclpObjListVolumes.  Objectified 
	internal call signatures for 'file attributes' functions, and
	added an internal objectified get path type function.
	* generic/tclIOUtil.c: added the moved function TclpListVolumes 
	which calls platform specific code (needed for backwards 
	compatibility), and improved efficiency of parts of the FS
	(particularly file normalization).  Much less copying and
	memory allocation is required now.  added new GetPathType 
	so that changes in 'file volumes' can actually affect files'
	types, and objectified more code.  Made current code work
	with test suite artificially changing current platform.
	Added 'static' keywords where required.
	* generic/tclIO.c:
	* generic/tclTest.c: Added 'static' keywords, fixing 
	[Bug: 453872, Bob Techentin]
	* generic/tclCmdAH.c: file command implementation updated for 
	API changes, removed unnecessary special-case SplitPath static
	function, since it no longer helps prevent code duplication.
	Moved setting of interpreter result to each individual location
	that actually required it, to avoid very large code separation
	between reading and setting the result.
	* doc/FileSystem.3: updated documentation for the new or 
	changed APIs, and clarified some issues.
	* doc/SplitPath.3: added pointer to newer APIs in FileSystem.3
	* doc/filename.n: clarified current implementation of tilde
	support on Mac/Win.  [Bug:453514, Sergey Kuzmin]
	* doc/glob.n: improved documentation for '-directory' and '-path' 
	options.
	
	There are now many private, obsolete, platform-specific 'Tclp' 
	string-based filesystem APIs which could be removed.  We should
	check whether any of these are used by extensions and, at least
	in Tcl 9, remove them.
	
	The above changes signify a ***POTENTIAL INCOMPATIBILITY*** 
	with 8.4a3, since signatures of two functions in the new API 
	have changed, but not with older versions of Tcl.

2001-08-23  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclBinary.c (FormatNumber): Extract a long from the
	object and not an int, to stop [binary format] from being unable
	to format some input numbers on architectures where sizeof(int) is
	less than sizeof(long) (particularly Alpha.)  [tiprender Bug #441861]

	* tests/format.test: Converted conditional execution of tests into
	a test constraint.

2001-08-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/Makefile.in:
	* win/makefile.vc: updated install target for dde1.2
	* doc/dde.n: fixed dde man page (which was totally incorrect).
	* tests/winDde.test:
	* win/tclWinDde.c (Tcl_DdeObjCmd): added -binary option to dde
	request command to allow for returning binary data. [Bug #227482]
	Updated dde to 1.2

	* tests/tcltest.test: added unixExecs constraint to files that
	used 'grep' in the test. [Bug #453143]

	* library/tcltest/tcltest.tcl: fixed stdio constraint test.
	[Patch #454050] (stanton)
	Simplified unixExecs constraint test. 
	
2001-08-22  Don Porter <dgp@users.sourceforge.net>

	* tests/ioUtil.test (ioUtil-3.*): Corrected errors in tests
	revealed by fix of overagressive compiler.  [Bug 451200]

2001-08-21  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c:
	* tests/compile.test: Fixed overagressive compilation of [catch]:
	it was catching errors at substitution time. [Bug #219184]
	
2001-08-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/tcltest.test (tcltest-12.2): fixed test that would break
	when env vars weren't Tcl list friendly [Patch #454046] (stanton)

2001-08-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/http/http.tcl (geturl): added port number to Host:
	header to comply with HTTP/1.1 spec (RFC 2068).  [Bug #452217]

2001-08-16  David Gravereaux <davygrvy@pobox.com>

	* tools/tcl.wse.in:
	* tools/tcl.hpj.in:
	* win/tcl.hpj.in:  Removed -kb storage in CVS to ensure these text
	files are checked-out in the translation mode CVS is in.  Setting
	these as binary as part of an effort to make sure they are always
	in CRLF, no matter what the CVS translation, is bypassing how CVS
	works and is confusing.

	* tools/genStubs.tcl:  Removed LF-only output.  Having to reconvert
	back to CRLF before committing to CVS was giving me a headache.
	[Bug: 451333]

	* win/makefile.vc: replaced $(WINDIR) with $(include32) for the
	.rc.res inference rule.  winver.h wasn't getting included.
	[Bug: 445630]

2001-08-14  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c: make the intial maxNestingDepth of an
	interpreter be MAX_NESTING_DEPTH instead of a hardwired value
	[Bug: 232564]

2001-08-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/trace.test: Corrected test numbers [Bug: 449794] 

2001-08-12  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in:
	* unix/tcl.m4: Use GCC variable set by AC_PROG_CC instead
	of defining our own using_gcc variable.

2001-08-11  Vince Darley <vincentdarley@users.sourceforge.net>

        Variety of small issues introduced by the vfs code fixed:
	* generic/tclIOUtil.c: uninitialised read.
	* generic/tclFCmd.c: possible memory leak in file delete 
	with error condition.

2001-08-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: 
	* tests/trace.test: Insure that [array] traces work correctly for
	undefined variables [Bug: 449094] 

2001-08-09  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Delete the unused getcwd.o
	target. This fixes bug #440942.

2001-08-08  Don Porter <dgp@users.sourceforge.net>

	* library/dde/pkgIndex.tcl:
	* library/http/http.tcl:
	* library/http/pkgIndex.tcl:
	* library/msgcat/msgcat.tcl:
	* library/msgcat/pkgIndex.tcl:
	* library/opt/optparse.tcl:
	* library/opt/pkgIndex.tcl:
	* library/reg/pkgIndex.tcl:
	* library/tcltest/tcltest.tcl:
	* library/tcltest/pkgIndex.tcl: Added checks for package dependencies.
	Bumped patchlevels of changed packages:  http 2.3.2, msgcat 1.2.2,
	opt 0.4.3, tcltest 2.0.1.  [Patch 448931]

	* README:
	* generic/tcl.h:
	* tools/tcl.wse.in:
	* unix/configure:
	* unix/configure.in:
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure:
	* win/configure.in: Bumped up patchlevel to 8.4a4 to distinguish
	CVS snapshots from the 8.4a3 release.  This does not necessarily
	mean there will be an 8.4a4 release.  [Bug 448938].

2001-08-06  Jeff Hobbs  <jeffh@ActiveState.com>

	8.4a3 RELEASE

	* changes:
	* README:
	* mac/README: 
	* unix/README:
	* win/README.binary: updated for 8.4a3 release

	* generic/tclFileName.c (Tcl_FSSplitPath): update to Tcl style
	guide.

	* generic/tclFCmd.c (FileCopyRename): fixed mem leak in
	introduction of vfs code where a new Tcl_Obj wasn't freed.

	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd):
	reordered the retrieval of arguments to avoid shimmering bug when
	the pattern and string referenced the same object.

	* unix/configure: regenerated
	* unix/tcl.m4: added GNU (HURD) configuration target. (brinkmann)
	[Patch: #442974]

	* win/README: made note of URL for Windows compilation notes

	* win/tclWinThrd.c (TclpFinalizeMutex, TclpFinalizeCondition):
	added DeleteCriticalSection calls for cleanup [Patch: #419683]

	* unix/tclUnixPipe.c (TclpCreateTempFile): fixed use of tmpnam,
	which is dangerous. [Patch: #442636] (lim)
	The use of tmpnam in TclpTempFileName must still be changed.

	* tests/http.test (http-4.14): fixed variable error return.
	[Bug: 424252]

2001-08-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/configure: regenerated
	* win/tcl.m4: fixed DLLSUFFIX definition to always be ${DBGX}.dll.
	This is necessary for TEA compliant builds that build shared
	against a static-built Tcl.
	* win/Makefile.in ($(TCLSH)): added $(TCL_STUB_LIB_FILE) to build
	target, otherwise it wouldn't get generated in a static build.

2001-08-06  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclIOCmd.c (Tcl_GetsObjCmd): Applied patch from SF item
	  [442665] to fix the bug reported by it. The function can corrupt
	  a freed object if it is called with objc == 3. This is because
	  it retrieves resultPtr and does not increment its reference
	  count, but then calls Tcl_ObjSetVar2, which causes the retrieved
	  resultPtr object to be released.
	
2001-08-06  Don Porter <dgp@users.sourceforge.net>

	* doc/tclsh.1:  Added note that the tclsh program is frequently
	installed with the Tcl version numer as part of the name.
	[Patch 402725]

	* generic/tclPkg.c:
	* tests/pkg.test:  [package forget] now forgets all of the
	package arguments it receives, not stopping when a package is
	not found.  [Bug 415273]

2001-08-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclIOUtil.c (Tcl_FSMatchInDirectory): corrected
	uninitialized value.

2001-08-02  Mo DeJong  <mdejong@redhat.com>

	* generic/tclPlatDecls.h:
	* win/tclWinPort.h:
	Revert <tchar.h> related changes made to improve
	Cygwin support on 2001-07-18. This change ended
	up breaking the VC++ build because of conflicts
	between Windows APIs and internal Tk APIs.

2001-08-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/tclUnixFCmd.c: minor casts to eliminate warnings. (lim)
	[Patch: #440218]

	* tests/parseOld.test: changed some tests that required
	testwordend to exist to skip in a proper tcltest manner.
	[Bug: #442663]

	* library/http/http.tcl (http::mapReply): the regsub'ing of \n and
	\t to escape them was unnecessary.

2001-07-31  Vince Darley <vincentdarley@users.sourceforge.net>

        Changes from TIP#17 "Redo Tcl's filesystem"
	The following files were impacted:
	* doc/Access.3: 
	* doc/FileSystem.3: 
	* doc/OpenFileChnl.3: 
	* doc/file.n: 
	* doc/glob.n: 
	* generic/tcl.decls: 
	* generic/tcl.h: 
	* generic/tclCmdAH.c: 
	* generic/tclCmdIL.c: 
	* generic/tclCmdMZ.c: 
	* generic/tclDate.c: 
	* generic/tclDecls.h: 
	* generic/tclEncoding.c: 
	* generic/tclFCmd.c: 
	* generic/tclFileName.c: 
	* generic/tclGetDate.y: 
	* generic/tclIO.c: 
	* generic/tclIOCmd.c: 
	* generic/tclIOUtil.c: 
	* generic/tclInt.decls: 
	* generic/tclInt.h: 
	* generic/tclIntDecls.h: 
	* generic/tclLoad.c: 
	* generic/tclStubInit.c: 
	* generic/tclTest.c: 
	* generic/tclUtil.c: 
	* library/init.tcl: 
	* mac/tclMacFCmd.c: 
	* mac/tclMacFile.c: 
	* mac/tclMacInit.c: 
	* mac/tclMacPort.h: 
	* mac/tclMacResource.c: 
	* mac/tclMacTime.c: 
	* tests/cmdAH.test: 
	* tests/event.test: 
	* tests/fCmd.test: 
	* tests/fileName.test: 
	* tests/io.test: 
	* tests/ioCmd.test: 
	* tests/proc-old.test: 
	* tests/registry.test: 
	* tests/unixFCmd.test: 
	* tests/winDde.test: 
	* tests/winFCmd.test: 
	* unix/mkLinks: 
	* unix/tclUnixFCmd.c: 
	* unix/tclUnixFile.c: 
	* unix/tclUnixInit.c: 
	* unix/tclUnixPipe.c: 
	* win/tclWinFCmd.c: 
	* win/tclWinFile.c: 
	* win/tclWinInit.c: 
	* win/tclWinPipe.c

2001-07-24  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinThrd.c (Tcl_CreateThread): Close Windows
	HANDLE returned by _beginthreadex. The MS documentation
	states that this handle is not closed by a later call to
	_endthreadex.

2001-07-21  Don Porter  <dgp@users.sourceforge.net>

	* doc/pkgMkindex.n:
	* library/package.tcl:  Corrected documentation and usage
	message of [pkg_mkIndex].

2001-07-18  Mo DeJong  <mdejong@redhat.com>

	* generic/tclPlatDecls.h: Define TCHAR by including
	windows.h instead of tchar.h since Cygwin does not
	support the tchar.h header. Include CHECK_UNICODE_CALLS
	logic from tclWinPort.h.
	* win/tclWinPort.h: Remove CHECK_UNICODE_CALLS logic.
	Remove include of windows.h since this now done it
	tclPlatDecls.h.
	* win/tclWinReg.c: Remove duplicate include of windows.h.

2001-07-18  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclIO.c: Aftermath to [SF #427196]. Squash empty buffers
	  if they are smaller than the requested buffersize, to prevent
	  reusage of old buffers and to honor changes in the requested
	  buffersize made by the user.

2001-07-17  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinFile.c (TclpReadlink): Add Cygwin specific definition
	for the TclpReadlink function. This method implements reading of
	symbolic links when build with Cygwin.

2001-07-17  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinPort.h: Add Cygwin specific defines for environ
	and timezone variables.

2001-07-17  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclIO.c (GetInput): Fixed [SF #427196]. Memory was
	  overwritten because a buffer was used after a change of the
	  requested buffersize together with that requested buffersize and
	  not its actual size, which was smaller. Note that the continous
	  reuse of the smaller buffer negatively impacts performance. The
	  system never allocates a buffer with the newly requested bigger
	  buffersize.

2001-07-16  Mo DeJong  <mdejong@redhat.com>

	* generic/tcl.h: Define __WIN32__ when
	__CYGWIN__ or __MINGW32__ is defined.
	* generic/tclAlloc.c: Define caddr_t when
	compiling with VC++ or mingw. This type is
	already defined when compiling with Cygwin.

2001-07-16  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinConsole.c:
	* win/tclWinPipe.c:
	* win/tclWinPort.h:
	* win/tclWinSerial.c:
	* win/tclWinThrd.c:
	Remove unnecessary #includes of dos.h, direct.h,
	and tchar.h. This will help the Cygwin porting
	effort since these headers do not exist under Cygwin.

2001-07-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinPipe.c (PipeClose2Proc): constrained the mutex lock to
	just the TerminateThread call and waiting for termination. (jsmith)

	* generic/tclCmdMZ.c: Removed extra copy of the SCAN_* macros
	#defined in generic/tclScan.c. (porter) [Bug 441230]

2001-07-12  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-2.8): Added extra constraint,
	notInstalledInTmp, to stop this test from damaging installations
	in /tmp; not much fun to have to reinstall the Tcl library every
	time you run the test suite!

	* tests/subst.test (subst-10.*): Updated tests to check new
	behaviour for 'break' in command substitutions.
	(subst-1.2,subst-7.1): Error messages changed.
	* doc/SubstObj.3: New file, to document Tcl_SubstObj.
	* doc/subst.n: Improved and updated documentation for 'subst' to
	help support the changed behaviour.
	* generic/tcl.decls (generic-437): Declaration for Tcl_SubstObj
	* generic/tcl.h (TCL_SUBST_*): Added flags for Tcl_SubstObj.
	* generic/tclCmdMZ.c (Tcl_SubstObj,Tcl_SubstObjCmd): Divided into
	two parts to allow people to access the innards of 'subst' and
	changed the behaviour when command substitutions do a 'break' to
	be different from 'continue'.  Also now works with objects, which
	allows for some nifty optimisations with variable substitutions
	and a slight improvement with command substitutions.  [TIP#36]

2001-07-10  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Add AR variable for use in STLIB_LD.
	* unix/configure: Regen.
	* unix/configure.in: Use STLIB_LD when defining MAKE_LIB
	and MAKE_STUB_LIB. Subst RANLIB and AR.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Add doc comment about
	STLIB_LD command. Check ${AR} env var when setting
	STLIB_LD and delay evaluation until make time.
	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Delay evaluation of
	${AR} in STLIB_LD and add flags to better match the
	Unix implementation. Don't bother defining AR when
	using VC++ since it is not used.

2001-07-06  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Pass -e _WinMain@16 in
	addition to the -mwindows flag to work around a problem
	with ld when it incorrectly use main() as the executable
	entry point when both WinMain() and main() are available.

2001-07-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdAH.test: Added leading zero to file modes to work
	around fault in HPUX strtol() which ignores the base parameter
	[Bug #438808]

2001-07-05  Mo DeJong  <mdejong@redhat.com>

	* win/Makefile.in: Subst DEPARG directly instead
	of relying on a variable. This will make Cygwin
	builds faster since an extra exec will be avoided.
	* win/configure: Regen.
	* win/configure.in: Subst DEPARG.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Move AC_MSG_CHECKING
	after the AC_CHECK_PROG so that status messages do
	not get mixed together. Set DEPARG based on the
	results of the cygpath check so that we avoid using
	an extra exec when it is not needed. Use ac_cv_cygwin
	status flag instead of looking at the output of
	gcc -v, which works in the case where -mno-cygwin is
	set in the CFLAGS.

2001-07-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* README:
	* mac/README:
	* unix/README:
	* win/README:
	* win/README.binary: updated READMEs with purls

2001-07-03  Mo DeJong  <mdejong@redhat.com>

	* win/Makefile.in: Remove PATHTYPE variable.
	* win/configure: Regen.
	* win/configure.in: Don't subst PATHTYPE.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Remove PATHTYPE
	variable. Set CYGPATH to "cygpath -w" if the
	cygpath executable is found on the path. This
	approach works for native Cygwin builds and
	cross compiles.

2001-07-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/var.test:
	* generic/tclVar.c (Tcl_VariableObjCmd): added patch to check for
	number of args. [Patch #426038]

	* generic/tclVar.c (Tcl_GetVar2Ex): added ability to recognize
	TCL_TRACE_READS flags to cause creation of part1 in TclLookupVar
	to make sure newly created array will get read traces triggered
	appropriately.  This is called by Tcl_ObjGetVar2, Tcl_GetVar, and
	Tcl_GetVar2.
	(TclSetIndexedScalar, TclSetElementOfIndexedArray): added read
	trace triggering for lappend case.
	(Tcl_LappendObjCmd): pass TCL_TRACE_READS to Tcl_ObjGetVar2 to
	trigger possible read traces for new arrays.

	* generic/tclExecute.c (TclExecuteByteCode): added TCL_TRACE_READS
	flag to INST_LAPPEND(_ARRAY)_STK case to trigger read traces for
	newly created arrays.  Removed unnecessary #ifdef for
	TCL_COMPILE_DEBUG in INST_LOAD_SCALAR1 case.

	* tests/append.test:
	* tests/appendComp.test: added tests for read trace triggering for
	append and lappend.

2001-07-03  Mo DeJong  <mdejong@redhat.com>

	* tests/clock.test (clock-2.5): Adjust test so that it passes
	when the time slice is 60 msecs, now passes under Windows 98.

2001-07-03  Mo DeJong  <mdejong@redhat.com>

	* win/tcl.m4 (SC_CONFIG_CFLAGS): Don't pass the v flag
	to ${AR} when using gcc, verbose output is not needed.

2001-07-03  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-2.8):  Changed test back to using
	installation layout, adding comments explaining why the test writes
	to the directories it does, and checks to avoid destroying other
	files in /tmp.

2001-07-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-1.2): Fixed faults reported in
	Bug#438070 - well, at least enough to work on Solaris - and added
	comments that should make what is going on in the test clearer.

2001-07-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/util.test: added util-4.6
	* generic/tclUtil.c (Tcl_ConcatObj): Corrected walking backwards
	over utf-8 chars. [Bug #227512]

2001-07-02  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-2.8):  Corrected test for all
	absolute pathnames in library path when executable is installed
	near root directory to use correct development directory layout.
	[Bug 438014]

	* tests/unixInit.test (unixInit-2.9):  
	* unix/tclUnixInit.c (TclpInitLibraryPath):
	* win/tclWinInit.c (TclpInitLibraryPath):  Corrected buggy
	construction of search path entries relative to executable.
	Added test for bad construction.  [Bug 438014]

2001-06-28  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclNamesp.c: Correction to faulty patch from [Bug: 231259] 

2001-06-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-1.2): Modified so as not to
	require a local echo service, which fails on many systems which
	have that turned off for security reasons...

2001-06-27  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclInt.h:
	* generic/tclObj.c:
	* unix/Makefile.in: added a -DPURIFY mode that makes Tcl_Obj's
	allocated and free singularly (instead of in alloc in blocks and
	never free) to allow checkers like Purify to operate better.

	* library/encoding/koi8-u.enc: added koi8-u (Ukranian variant)
	encoding.

	* tests/subst.test:
	* generic/tclUtf.c (Tcl_UtfBackslash): Corrected backslash
	handling of multibyte utf-8 chars. [Bug #217987]

	* generic/tclCmdIL.c (InfoProcsCmd): fixed potential mem leak in
	info procs that created objects without using them.

	* generic/tclCompCmds.c (TclCompileStringCmd): fixed mem leak when
	string command failed to parse the subcommand.

	* doc/interp.n:
	* doc/unknown.n: updated notes about what is in a safe interp.
	[Bug #218605]

2001-06-27  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/event.test (event-11.5): Removed hard-coded port number
	which could fail on some systems.  [Bug #436727]

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in:
	* win/Makefile.in: Add `make shell` target. This target
	will set the proper env vars before invoking tclsh
	from the build directory.

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* win/Makefile.in: Use : to separate VPATH entries. This
	works for both Cygwin builds and cross builds, the VPSEP
	variable is simply unneeded complexity.
	* win/configure: Regen.
	* win/configure.in: Don't subst VPSEP.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Remove VPSEP variable.

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in: Fix last checkin by removing
	export since that only works in bash.
	* win/configure: Regen.
	* win/configure.in: Ditto.

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in: Set CFLAGS to "" if the user
	did not set CFLAGS in the env. This keeps AC_PROG_CC
	from adding "-g -O2" to the CFLAGS by default.
	* win/configure: Regen.
	* win/configure.in: Ditto.

2001-06-25  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/configure.in: Use RC_DEFINE flag from tcl.m4.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Set RC_DEFINE
	flag based on the compiler in use.
	
2001-06-25  Mo DeJong  <mdejong@redhat.com>

	* win/tcl.m4 (SC_CONFIG_CFLAGS): Link to the
	imm32 library when building with mingw gcc.

2001-06-25  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): When building with
	gcc, don't attempt to link with LD or support dllwrap.
	Simply require a recent version of Cygwin gcc or Mingw
	gcc that supports -shared. When linking, use gcc instead
	of ld since gcc automatically includes libs like -lmsvcrt.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/configure.in: Add resource compiler fix from
	8.3.3 to fix compiling with mingw.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/tcl.m4: Fix silly typo in last checkin.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
	Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@. Add LDFLAGS_DEBUG
	and LDFLAGS_OPTIMIZE to match the way CFLAGS_DEFAULT works.
 	This will support user set CFLAGS or LDFLAGS at configure time.
	* unix/configure: Regen.
	* unix/configure.in: Don't set CFLAGS to CFLAGS_DEFAULT, instead
	subst CFLAGS_DEFAULT into the Makefile. Add AC_SUBST for CFLAGS_DEFAULT,
	LDFLAGS_DEFAULT, LDFLAGS_DEBUG, and LDFLAGS_OPTIMIZE.
	* unix/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
	it uses a Makefile variable just like CFLAGS_DEFAULT.
	* win/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
	Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@.
	This will support user set CFLAGS or LDFLAGS at configure time.
	* win/configure: Regen.
	* win/configure.in: Don't set CFLAGS or LDFLAGS, instead subst
	CFLAGS_DEFAULT and LDFLAGS_DEFAULT into the Makefile.
	* win/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
	it uses a Makefile variable just like CFLAGS_DEFAULT.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* win/configure:
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Don't set LDFLAGS_DEBUG
	to -g or LDFLAGS_OPTIMIZE to -O when compiling with gcc.
	These flags are not needed and can cause problems with
	the Cygwin version of ld.

2001-06-18  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-1.2,unixInit-2.8): Added test for
	code described below, and fixed a couple of errors that caused
	problems during testing; the code to determine the installedTcl
	constraint was wrong, and test unixInit-2.8 assumed that /tmp/lib
	was free for use and could be deleted, which clashed nastily with
	my installation and made other tests fail unnecessarily!

	* unix/tclUnixChan.c (TtyInit,TclpOpenFileChannel,
	Tcl_MakeFileChannel,TclpGetDefaultStdChannel): Alterations so that
	the standard channels - stdin, stdout and stderr - have the
	correct type and fconfigure options.  This required making the
	initialisation of serial lines a little more sophisticated to
	make the console behave correctly in interactive mode... [Bug
	#219137 and duplicates]

2001-06-16  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclInt.decls:
	* generic/tclInt.h: 
	* generic/tclPanic.c (Tcl_PanicVA):
	* mac/tclMacAppInit.c (main):
	* mac/tclMacPanic.c (TclpPanic):
	* unix/tclUnixPort.h:
	* win/tclWinPort.h: Replaced TclMacSetPanic with TclpPanic
	for setting a platform-specific panic handler.  TclpPanic
	is NULL on Unix and Windows.  Fixes broken wish on Mac due
	to earlier patches.  [Patch 415648]
	
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: `make gentubs` after above changes.

2001-06-13  Don Porter  <dgp@users.sourceforge.net>

	* mac/tclMacAppInit.c (main, Macintosh_Init):
	* mac/tclMacBOAAppInit.c (main):
	* mac/tclMacPanic.c: Applied patches from Dan Steffen correcting
	problems on the Macintosh in the 2001-06-08 changes.

2001-06-12  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/regexp.test (regexp-18.12): 
	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): Fixed so that submatches
	that do not match always have index pair {-1 -1} [Bug #219232]

2001-06-08  Don Porter  <dgp@users.sourceforge.net>

	* generic/tcl.h:
	* generic/tcl.decls:
	* generic/tclPanic.c: Added CONST to Tcl_*Panic* public interfaces.
	[Patch 415648, TIP 27]

	* generic/tclInt.decls:
	* mac/tclMacAppInit.c (main):
	* mac/tclMacBOAAppInit.c (main):
	* mac/tclMacPanic.c: Modified special Mac implementations of
	Tcl_*Panic* to be exact copies of the generic implementations.
	Added TclMacSetPanic.  The generic implementations should be
	used directly, rather than copies, but that requires further
	changes by someone familiar with the Mac build systems.
	[Patch 415648]

	* generic/tclDecls.h:
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: `make gentubs` after above changes.

	* doc/Panic.3:
	* unix/mkLinks:  New file documenting Tcl_*Panic* public interfaces,
	followed by `make mklinks`.  [Patch 415648, Bug 219170, Bug 414936]

2001-06-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclUtil.c (Tcl_DStringAppendElement): patch to save an
	extra strlen call.  [Bug #428572]

2001-05-30  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclExecute.c (TclExecuteByteCode): Added two casts to
	INST_STR_CMP implementation to get rid of a couple warnings from
	the SUNWspro C compiler.

	* generic/tclBasic.c (Tcl_GetMathFuncInfo,Tcl_ListMathFuncs): 
	* generic/tclCmdIL.c (Tcl_InfoObjCmd,InfoFunctionsCmd): 
	* generic/tcl.decls (generic table, positions 435+436): 
	* tests/info.test: 
	* doc/CrtMathFnc.3: 
	* doc/info.n: Changes due to TIP #15 "Functions to List and Detail
	Math Functions"

2001-05-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/init.tcl (unknown): removed errant " in error message

2001-05-27  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/regc_locale.c: updated character class range data for
	Unicode v3.1.0 compliance.
	* generic/tclUniData.c: regenerated from Unicode v3.1.0 data file
	(new as of 2001-05-16).  This brings Tcl to current unicode
	compliance.

	* tests/utf.test: added tests to check unicode 3 compliance

	* unix/Makefile.in (tclUtf.o): added tclUniData.c dependency.

	* tools/uniClass.tcl: added comments to output format and the
	script for clarification.

	* tools/uniParse.tcl: corrected filename output and GetDelta macro
	to use 'info' as param (was 'infO')

2001-05-26  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclVar.c (tclArraySearchType,SetArraySearchObj,
	ParseSearchId): Added code to speed up array searching by reducing
	the amount of parsing needed for searchIds.

	* generic/tclObj.c (TclInitObjSubsystem): 
	* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): 
	* generic/tclNamesp.c (TclInitNamespaceSubsystem): 
	* generic/tclInt.h: Moved some Tcl_ObjType initialisation to
	TclInitObjSubsystem to be with the bulk of the rest.
	[Patch 424851] Committed by Miguel Sofer <mig@utdt.edu>

2001-05-23  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/io.test: changed io-52.[9-11] to not be platform sensitive
	with EOL translation.

	* library/encoding/cp1250.enc:
	* library/encoding/cp1251.enc:
	* library/encoding/cp1252.enc:
	* library/encoding/cp1253.enc:
	* library/encoding/cp1254.enc:
	* library/encoding/cp1255.enc:
	* library/encoding/cp1256.enc:
	* library/encoding/cp1257.enc:
	* library/encoding/cp1258.enc:
	* library/encoding/cp874.enc:
	* library/encoding/iso8859-6.enc:
	* library/encoding/iso8859-7.enc:
	* library/encoding/iso8859-8.enc:
	* library/encoding/iso8859-10.enc (new):
	* library/encoding/iso8859-13.enc (new):
	* library/encoding/iso8859-14.enc (new): updated encoding tables
	based on http://www.unicode.org/Public/MAPPINGS/. (kuhn)

2001-05-23  Mo DeJong  <mdejong@redhat.com>

	* unix/tcl.m4 (SC_PATH_TCLCONFIG): Fix comments,
	and typo in cached variable name.

2001-05-23  Mo DeJong  <mdejong@redhat.com>

	* unix/tcl.m4 (SC_LOAD_TKCONFIG):
	Remove use of undefined TCLCONFIG variable and
	call AC_MSG_RESULT to print the checking result.
	* win/tcl.m4: Ditto.

2001-05-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclObj.c (TclAllocateFreeObjects): simplified
	objSizePlusPadding to use sizeof(Tcl_Obj) (max)
	Corrected use of tclObjsAlloced/Freed/Shared in TCL_MEM_DEBUG
	compile.

2001-05-22  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: removed Tcl_DuplicateObj in INST_DUP 

2001-05-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/tcltest.test (tcltest-19.1): fixed failing test that was
	getting affected by Windows env handling of empty valued elements.

	* unix/tcl.m4: added more common install directories in which to
	search for *Config.sh [Bug #419812]

	* tests/cmdMZ.test (cmdMZ-1.4): added notLinux constraint to test
	to prevent failure message on Linux due to OS caching bug.

	* tests/httpd (httpdRespond): added response to timeout value in
	query string.

	* tests/http.test: removed unused notLinux constraint setting

	* generic/tclRegexp.c (Tcl_RegExpExecObj): added use of
	Tcl_GetUnicodeFromObj.

2001-05-19  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* Note that "tclbench" (see project "tcllib") was extended with
	  performance benchmarks for [fcopy] too.

	* doc/fcopy.n: Updated to reflect the extended behaviour of 'fcopy'.

	* tests/io.test: Added tests 'io-52.9', 'io-52.10' and 'io-52.11'
	  to test the handling of encodings by 'fcopy' / 'TclCopychannel'
	  [Bug #209210].

	* generic/tclIO.c: Split of both 'Tcl_ReadChars' and
	  'Tcl_WriteChars' into a public error checking and an internal
	  working part. The public functions now use the new internal
	  ones. The new functions are 'DoReadChars' and 'DoWriteChars'.
	  Extended 'CopyData' to use the new functions 'DoXChars' when
	  required by the encodings on the input and output channels
	  [Bug #209210].

2001-05-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/history.tcl (tcl::HistAdd): prevent empty calls from
	being added to the history (arndt)

	* tests/error.test: updated error-1.3 message to account for
	string index being compiled at toplevel.
	* tests/appendComp.test:
	* tests/stringComp.test: new files for extended bytecode testing

	* generic/tclBasic.c: added new CompileProc invocations to basic
	command initialization.
	* generic/tclCompCmds.c: added new compile commands for append,
	lappend, lindex and llength.  Refactored set and incr compile
	commands to use new TclPushVarName function for handling the
	varname component during compilation (also used by append and
	lappend).  Changed string compile command to compile toplevel code
	as well (when possible).
	* generic/tclCompile.c: added new instruction enums
	* generic/tclCompile.h: added debug info for new instructions
	* generic/tclExecute.c (TclExecuteByteCode): moved elemPtr to
	toplevel var (oft-used).  Added definitions for new bytecode
	instructions INST_LIST_INDEX, INST_LIST_LENGTH, INST_APPEND_SCALAR1,
	INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4,
	INST_APPEND_ARRAY_STK, INST_APPEND_STK, INST_LAPPEND_SCALAR1,
	INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4,
	INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK.
	Refactored repititious code for reuse with INST_LOAD_STK (same as
	INST_LOAD_SCALAR_STK), INST_STORE_STK (same as
	INST_STORE_SCALAR_STK).
	Updated INST_STR_CMP with style of fix of 2001-04-06 Fellows
	[Bug #219201] as that fix only affected the runtime eval'ed
	"string" (string compare is normally byte-compiled now).  We
	may want to back these out for speed in the future, noting the
	problems with \x00 comparisons in the docs.
	* generic/tclInt.h: declarations for new compile commands.
	* generic/tclVar.c: change TclGetIndexedScalar,
	TclGetElementOfIndexedArray, TclSetElementOfIndexedArray and
	TclSetIndexedScalar to use flags.  The Set functions now support
	TCL_APPEND_ELEMENT and TCL_LIST_ELEMENT as well.
	* generic/tclInt.decls:
	* generic/tclIntDecls.h: minor signature changes for above.

	* generic/tclCmdMZ.c: made use of new Tcl_GetUnicodeFromObj.

2001-05-16  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/console.n: Deleted.  Put it in the wrong source tree!  D'oh!

2001-05-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tcl.decls:
	* generic/tclDecls.h:
	* generic/tclStubInit.c:
	* generic/tclStringObj.c (Tcl_GetUnicodeFromObj): new function to
	parallel Tcl_GetStringFromObj (fix of an API oversight).

	* unix/tclUnixPipe.c: updated pipeChannelType to
	TCL_CHANNEL_VERSION_2 type specification.

	* tests/fileName.test: corrected tests not to fail on win when a
	C:/test dir exists.

	* generic/tclFileName.c (ExtractWinRoot): corrected ABR error

2001-05-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/lindex.test: added test for nested braces [Patch: 423617]

2001-05-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclInt.h
	* generic/tclNamesp.c: invalidate all bytecodes in a namespace if
	a new command shadows a bytecoded command.
	* tests/namespace.test
	Patched from [Bug: 231259] 

2001-05-15  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/console.n: Created.  It seems very odd to me that the
	console implementation is part of the Tcl distribution and not
	part of Tk, but given the location of the source, the
	documentation must obviously match up...

2001-05-14  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCmdMZ.c (Tcl_StringObjCmd): 
	* tests/string.test (string-4.14): Negative string indices should
	not be added as offsets to the result of [string first] but
	instead be treated as referring to the start of the string.
	[Bug: 423581]

2001-05-11  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Add a LDFLAGS variable to the
	Makefile instead of directly substing @LDFLAGS@.
	* unix/configure: Regen.
	* unix/tcl.m4: Fix CFLAGS_DEFAULT so that the name
	of a Makefile variable is passed as @CFLAGS@.
	* win/Makefile.in: Move the setting of CFLAGS
	higher up in the Makefile.
	* win/configure: Regen.
	* win/configure.in: Use dnl to comment out macros
	so that they are not accidently expanded.
	* win/tcl.m4: Fix CFLAGS_DEFAULT so that the name
	of a Makefile variable is passed as @CFLAGS@.

2001-05-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: insure different rand() seeds in different
	threads [Bug 416643]

2001-05-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/tcltest.test: removed extraneous 'c' (doh!) [Bug: 414031]

	* tools/tcltk-man2html.tcl: removed use of 'exec' for portability
	and fixed up code.

2001-05-03  Don Porter  <dgp@users.sourceforge.net>

	* doc/library.n:
	* library/init.tcl:
	* tests/autoMkindex.t*: Modified [auto_import] to apply
	pattern matching in the [namespace import] style.  [Bug 420186]
	***POTENTIAL INCOMPATIBILITY*** for any callers of [auto_import]
	from outside Tcl that expect the pattern matching to be like that
	of [string match].

2001-05-03  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclParse.c: 
	* tests/namespace.test: Insure consistent behaviour of the
	[unknown] command: when a command is unknown, it is always
	processed by [::unknown], ignoring any namespace proc which
	happens to be called "unknown" [Patch #421166, Bug #420507]

2001-05-02  Don Porter  <dgp@users.sourceforge.net>

	* tools/genStubs.tcl: Add a package require of Tcl 8
	at the beginning of the script so that the script
	will print a descriptive error message when run
	in an old Tcl 7 shell.

2001-04-27  Kevin Kenny	<kennykb@crd.ge.com>

	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclCmdIL.c:
	* generic/tclProc.c:
	* generic/tclVar.c: Added another collection of missing CONSTs
	related to TclGetNamespaceForQualName.
	* generic/tclIntDecls.h: Regenerated.
	
2001-04-25  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
	* unix/tclConfig.sh.in: Add TCL_THREADS variable.
	* win/configure: Regen.
	* win/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
	* win/tclConfig.sh.in: Add TCL_THREADS variable.

2001-04-25  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in: Use $@ in MAKE_LIB and MAKE_STUB_LIB
	commands instead of using a delayed subst variable. Replace
	instances of STUB_LIB_FILE with TCL_STUB_LIB_FILE.

2001-04-25  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Use TCL_STUB_LIB_FILE instead of STUB_LIB_FILE.
	* unix/configure: Regen.
	* unix/configure.in: Don't subst STUB_LIB_FILE, use TCL_STUB_LIB_FILE
	instead.

2001-04-25  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tools/encoding/iso8859-15.txt:
	* library/encoding/iso8859-15.enc: Oops! Got the full encoding
	wrong.  Should be fixed now...

	* tools/encoding/iso8859-15.txt:
	* library/encoding/iso8859-15.enc:
	* tools/tcl.wse.in: Added ISO 8859-15 (a.k.a. Latin-1 + Euro
	currency symbol) support.

	* generic/tclNamesp.c:
	* generic/tclBasic.c (TclRenameCommand): Missing CONST from
	several declarations relating to use of TclGetNamespaceForQualName

2001-04-24  Kevin B. Kenny    <kennykb@acm.org>
	* doc/AssocData.3:
	* doc/CrtCommand.3:
	* doc/CrtMathFnc.3:
	* doc/CrtObjCmd.3:
	* doc/ExprLong.3:
	* generic/tclBasic.c:
	* generic/tclCmdMZ.c:
	* doc/CrtSlave.3:
	* generic/tclNamesp.c:
	* generic/tcl.decls:
	* generic/tcl.h:
	* generic/tclInt.decls:
	* generic/tclInt.h: (TIP #27) Another round of CONST changes, this
	time adding CONST to the API's exported from tclBasic.c.
	[Patch #415179]
	***POTENTIAL INCOMPATIBILITY*** from 8.4a2, in which Vince
	Darley's changes to command tracing were added.  A const has been
	added to the type signature of one of the parameters to
	Tcl_CommandTraceProc.

2001-04-10  Kevin B. Kenny    <kennykb@acm.org>
	* unix/tclUnixTime.c: Altered code to use memcpy instead of
	structure assigments in an effort to achieve better K&R
	compatibility.
	
2001-04-10  Kevin B. Kenny    <kennykb@acm.org>

	* unix/tclUnixTime.c: Fixed silly typo in calls to 'gmtime' and
	'localtime' that broke the Linux build.

2001-04-09  Kevin B. Kenny    <kennykb@acm.org>

	* unix/tclLoadShl.c: Added DYNAMIC_PATH to the load flags so that
	the SHLIB_PATH will be searched for other libraries.  [Bug #219140]
	
2001-04-09  Kevin B. Kenny    <kennykb@acm.org>

	* unix/tcl.m4: Added _REENTRANT to Solaris build so that thread
	safe library routines are included.
	* unix/configure: Re-ran 'autoconf' with changed tcl.m4
	* tclUnixTime.c: Modified for thread safety of 'gmtime' and
	'localtime' system calls [Bugs #219136 and #232558]
	
2001-04-09  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/expr.test (expr-21.*): Tests to check below fix.
	* generic/tclParseExpr.c (GetLexeme): Now recognises the
	non-numeric boolean literals for what they are. It no longer makes
	sense for anyone to create functions with the same name as one of
	them, but this was true in 7.* as well [Bug #217777; finally!]

2001-04-07  Miguel Sofer <msofer@users.sourceforge.net>

	* generic/tclExecute.c: Avoid panic when there are extra items in
	  the tcl stack [Bug #406709, Patch #414470]
	* tests/foreach.test: test to exercise the patch

2001-04-07  Miguel Sofer <msofer@users.sourceforge.net>

	* doc/namespace.n: document correct functionality
	* generic/tclNamesp.c: corrected behaviour of [namespace code]
	(Bug #219385, Patch #403530)
	* library/init.tcl:
	* tests/namespace-old.test: test correct functionality
	* tests/namespace.test: test correct functionality

2001-04-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/Makefile.in (checkdoc): New target, checking the
	  definitions as found in the compiled library against the
	  manpages to find undocumented public functionality.

	* unix/mkLinks: Updated to include the new manpage.

	* doc/UniCharIsAlpha.3: New manpage documenting the Unicode
	  character classification APIs [Bug #218720].

2001-04-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/mkLinks: Updated to incorporate the changes below.

	* doc/StringObj.3: Added 'Tcl_AttemptSetObjLength' to the NAME
	  section. [Bug #414435].

	* doc/Alloc.3: Added both 'Tcl_AttemptAlloc' and
	  'Tcl_AttemptRealloc' to the NAME section. [Bug #414435].

	* doc/Utf.3: Added both 'Tcl_UniCharCaseMatch' and
	  'Tcl_UniCharNcasecmp' to the NAME section. [Bug #414435].

2001-04-06  Don Porter  <dgp@users.sourceforge.net>

	* library/init.tcl:
	* tests/init.test:  Modified processing of $::errorInfo by
	[unknown] when the auto-loaded command throws an error to better
	cover the tracks of auto-loading.  [Bug 219280, Patch 403551]

2001-04-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/read.n: Added section on "USE WITH SERIAL PORTS" to resolve
	[Bug #219402]

	* tests/string.test (string-2.30): Test for this case
	* generic/tclCmdMZ.c (Tcl_StringObjCmd, STR_COMPARE branch): Fixed
	problem caused by Utf-rep of \x00 being more than Utf-rep of \x01
	fooling memcmp by forcing everything through Utf-based
	comparisons.  Added optimizations for case where objects have a
	string/unicode-rep or a bytearray-rep (i.e. where we can perform
	comparisons on fixed-size units.) [Bug #219201]
	* generic/tclUtf.c (Tcl_UtfNcmp): Corrected seriously erroneous
	comment.

2001-04-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* doc/Macintosh.3: Removed duplicates from .SH line
	  [Bug #413983]. 

2001-04-05  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCmdMZ.c (Tcl_StringObjCmd): Fixed so will compile
	with K&R compilers [Patch #413844, Bug #413847]

2001-04-04  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclMain.c:  Patch from Kevin Kenny to restore support of
	  pre-ANSI compilers.  [Bug 413846, Patch 413842]

2001-04-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/mkLinks: Updated to contain the new manpage.

	* doc/Environment.3: New manpage, describes Tcl_PutEnv
	  [Bug #219171]. 

	* doc/Macintosh.3: New manpage describing the macintosh specific
	  parts of the public API [Bug #219169].

2001-04-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/configure:
	* unix/tcl.m4: extended test of termios vs. termio vs. sgtty to
	better detect result on Linux and when certain configure
	redirections are being used. (max) [Patch #402923; Bug #227412,
	#219194]

2001-04-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* generic/tclTest.c:
	* tests/io.tests: TIP #10 followup correcting a problem with the
	  original patch because of the lack of 'testthread id' for a
	  non-threaded compilation.

2001-04-04  Kevin Kenny <kennykb@acm.org>

	* doc/ByteArrObj.3:
	* doc/DumpActiveMemory.3:
	* doc/InitStubs.3:
	* doc/PkgRequire.3:
	* doc/StringObj.3:
	* generic/tcl.decls:
	* generic/tcl.h:
	* generic/tclBinary.c:
	* generic/tclCkalloc.c:
	* generic/tclDecls.h:
	* generic/tclListObj.c:
	* generic/tclObj.c:
	* generic/tclPkg.c:
	* generic/tclStringObj.c:
	* generic/tclStubLib.c:
	  (TIP#27) Changed a number of Tcl API's to accept "CONST char*"
	  in place of simple "char*". (kennykb) [Patch #404026]

2001-04-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclListObj.c (Tcl_SetListObj): set objPtr->length = 0 in
	empty object case to maintain sanctity of Tcl_Obj bytes/length
	pairing. (porter) [Patch #405998]

2001-04-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/mkLinks: Added 'Signal.3', 'Tcl_WaitPid'.

	* doc/DetachPids.3: Added description of 'Tcl_WaitPid' [Bug #219173].

	* doc/Signal.3: New man page describing the public API procedures
	  'Tcl_SignalId' and 'Tcl_SignalMsg' [Bug #219172].

2001-04-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* README:
	* win/README:
	* win/README.binary: further notes corrections.

	* win/configure:
	* win/tcl.m4 (SHLIB_LD):  added -incremental:no. [Bug #219381]

2001-04-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* README:
	* mac/README:
	* win/README:
	* win/README.binary:
	* unix/README: updated patchlevel information to 8.4a3 and
	updated links and notes.

	* generic/tcl.h:
	* tools/tcl.wse.in:
	* win/configure.in (VER):
	* win/configure:
	* unix/configure:
	* unix/configure.in (VER):
	* unix/tcl.spec: updated patchlevel information to 8.4a3

2001-03-30  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCkalloc.c (TclFinalizeMemorySubsystem): set curTagPtr
	to NULL to allow for reuse.
	* generic/tclEvent.c (Tcl_Finalize): moved the tsdPtr
	initialization inside the subsystemsInitialized check to prevent
	it potentially getting called twice during finalization.  (wu)
	[Patch #403532, Bug #219391]

	* generic/tclThreadTest.c (Tcl_ThreadObjCmd): cast fixes
	* generic/tclTest.c (TestChannelCmd): added cast to mollify
	Windows debug build.

	* win/tclWinSock.c (SocketEventProc): Fixed race condition in
	readability of socket on Windows.
	[Patch #410674, Bug #219205 #219333]

	* win/tcl.m4: added imm32.lib to LIBS_GUI for Tk IME support.

	* win/Makefile.in (install-libraries): removed extra \s that broke
	the target.
	(install-doc): improved install-* targets to use their base build
	dependency.

2001-03-30  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* All of the changes below belong to TIP #10 [Tcl I/O Enhancement:
	  Thread-Aware Channels]. See also [Patch #403358] at SF.

	* generic/tclIO.h (struct ChannelState, line 236f): Extended the
 	  structure with a new field of type 'Tcl_ThreadId' to hold the id
 	  of the thread currently managing all channels with this state.

	  Note: This structure is shared by all channels in a stack of
 	  transformations.

	* generic/tclIO.c (Tcl_CreateChannel, lines 1058-1065): Modified
 	  to store the Id of the current thread in the 'ChannelState' of
 	  the new channel.

	* generic/tclIO.c (Tcl_SpliceChannel, lines 2265-2270): Modified
 	  in the same manner as 'Tcl_CreateChannel' as the channel will be
 	  managed by the current thread afterward.

	* generic/tclIO.c   (Tcl_GetChannelThread, lines 1478-1503):
	* generic/tcl.decls (Tcl_GetChannelThread, lines 1504-1506): New
 	  API function to retrieve the Id of the managing thread from a
 	  channel. Implementation and declaration.

	* generic/tclTest.c (TestChannelCmd, lines 4520-4532): Added
 	  subcommand 'mthread' to query a channel about its managing
 	  thread.

2001-03-29  Mo DeJong  <mdejong@redhat.com>

	* tests/interp.test: Print out warning when
	testinterpdelete command is not defined.
	Add tests that checks to make sure a
	child interp inherits the parent's cwd.

2001-03-29  Jeff Hobbs  <jeffh@gimlet.activestate.com>

	* doc/tcltest.n: corrected incorrect macro usage.

	* doc/lsort.n: corrected unbalanced nroff macros.

	* unix/tclUnixPipe.c (TclpCreateTempFile): prevent potential race
	condition and security leak in tmp filename creation.
 	(max) [Patch #402924]

	* unix/configure:
	* unix/tcl.m4: corrected IRIX-5.x config to not use -n32.
 	(english) [Patch #403626]

	* unix/tclUnixThrd.c (Tcl_ConditionWait): fixed handling of
	timeout for threads (corrects excessive CPU usage issue for Tk on
	Unix in threaded Tcl environment). (ruppert) [Bug #411603]

2001-03-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/lsort.n: Added some notes that clarify the behaviour of
	[lsort] as well as a whole bunch of examples.  [Bug #219202]

2001-03-27  Jeff Hobbs  <jeffh@gimlet.activestate.com>

	* doc/Alloc.3: corrected docs to note that Tcl_Attempt* return
	char *'s, not ints. [Bug #411388]

	* tests/regexp.test (regexp-19.1):
	* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): fixed handling of nulls
	in subspec value.

2001-03-26  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclDecls.h (Tcl_InitCustomHashTable):  Correction to
	patch from 2001-01-18;  tclDecls.h was not generated using
	'make genstubs'.

2001-03-26  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* win/tclWinInt.h (tclWinTCharEncoding): Removed as now a static
	variable in win/tclWin32Dll.c instead.

2001-03-23  Jeff Hobbs  <jeffh@activestate.com>

	* generic/tclVar.c (Tcl_ArrayObjCmd): Corrected retrieval of
	resultPtr to prevent possible corruption.

	* generic/tclNamesp.c (Tcl_Import): Correctly freed a DString.
 	(lavana) [Patch #403755]

2001-03-15  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/set-old.test (set-old-7.2): Changed error behaviour of
	[unset] to agree with documentation, so must change test as well.

2001-03-14  Don Porter  <dgp@users.sourceforge.net>

	* library/package.tcl (pkg_mkIndex):  Added patch from Vince
	Darley to make [pkg_mkIndex -verbose] even more verbose.
	[Bug 219349, Patch 403529]

2001-03-13  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/info.n: Improved documentation for [info hostname].
	[Bug #403840]

	* generic/tclVar.c (Tcl_UnsetObjCmd): Made command behave as
	documented [issue remaining from bug #405769]

	* generic/tclCmdMZ.c (Tcl_StringObjCmd): A missing
	{return TCL_OK;} was causing memory corruption.  [Bug #408002]

	* generic/tclExecute.c (TclDeleteExecEnv, GrowEvaluationStack,
	TclExecuteByteCode): Added some casts to ClientData that are
	apparently needed on some architectures.

2001-03-12  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/string.test: Fixed some test numberings and added a test.
	[Patch #403229]

2001-03-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to
	avoid a read off the end of the argument array that could occur
	when executing something like [unset -nocomplain] was executed.
	Improved the error message given when too few arguments are given
	(-nocomplain should obviously be *before* --, not after it) and
	also modified the test suite to take account of that and the
	documentation to use the same improvement. [Bug 405769]

2001-03-02  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclExecute.c (TclExecuteByteCode): Fixed bug that could
	pass pointers to freed memory to command implementations, which
	most obviously caused some weird behaviour with [info level], but
	could have caused problems with user code and command traces too.
	[Bug 404865, Patch 405436]

2001-02-23  msofer  <msofer@users.sourceforge.net>
	* no changes; fixing up the missing comment in the previous one.
	Sorry.

2001-02-23  msofer  <msofer@ant.utdt>

	* /cvsroot/tcl/tcl/tests/execute.test:
	added test for evaluation of an expression in a variable; evals once
	by compiling, second time using the previous compilation

2001-02-18  Kevin B. Kenny  <kennykb@acm.org>

	* doc/clock.n: Updated documentation to reflect the addition of
	compat/strftime.c, including the correct formatting of
	ISO-8601:1988 fiscal week number (%V).
	
2001-02-15  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCmdMZ.c (Tcl_SplitObjCmd): Improved efficiency of
	splitting strings into individual characters by adding hash so
	that only one Tcl_Obj per character is created.  Improves
	performance of splitting of short strings and makes a huge
	difference to splitting of long strings, such as is done in the
	mime package in tcllib.  [Bug #131523]

2001-01-31  Don Porter  <dgp@users.sourceforge.net>

	* win/makefile.vc (install-libraries):  Corrected misdirected
	install directory for the msgcat 1.2 package.

2001-01-30  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclIO.c (CopyData): Moved code that updates the count
	of how many bytes are left to copy.  Corrects bug that when
	writing occurs in the background, the copy loop could be
	escaped without updating the count, causing CopyData() to try
	to copy more bytes than the toRead value originally passed to
	TclCopyChannel(), leading to hangs and misreporting of number
	of bytes copied. [Bug 118203, Patch 103432]

2001-01-18  Andreas Kupries  <a.kupries@westend.com>

	* Everything below belongs together, it fixes bug #123153.

	* generic/tcl.h (line 342): A bit more explanation about the
	  default value for TCL_PRESERVE_BINARY_COMPATABILITY.

	* generic/tcl.h (line 1208): Define the macro 'Tcl_InitHashTable'
	  only when TCL_PRESERVE_BINARY_COMPATIBILITY is not set
	  as it kills binary compatibility to 8.3 and earlier
	  versions. This is the main part of the patch/change.

	* generic/tcl.decls (line 1469):
	* generic/tclHash.c (Tcl_InitHashTable):
	* generic/tclHash.c (Tcl_InitHashTableEx):
	* generic/tclObj.c (Tcl_InitObjHashTable): Changed
	  'Tcl_InitHashTableEx' to 'Tcl_InitCustomHashTable'. This change
	  is more of an estethical nature, replacing the ubiquitous 'Ex'
	  suffix with a more meaningful name. The introduced binary
	  incompatibility is deemed acceptable as it is between alpha
	  versions.  Updated callers.

	* doc/Hash.3:
	* unix/mkLinks: Changed 'Tcl_InitHashTableEx' to
	  'Tcl_InitCustomHashTable'.

2001-01-10  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/winPipe.test (winpipe-1.20): 
	* tests/winDde.test (createChildProcess): 
	* tests/pkgMkIndex.test (pkgtest::createIndex):  Removed
	assumption that paths contain no spaces which causes problems with
	both [eval] and [open |...] due to the well-known differences
	between lists and strings.  Fixes bug #119406

2001-01-04  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test:
	* unix/tclUnixInit.c (TclpInitLibraryPath):
	* win/tclWinInit.c (TclpInitLibraryPath):  Several entries in
	the library path ($tcl_libPath) are determined relative to the
	absolute path of the executable.  When the executable is
	installed in or near the root directory of the file system,
	relative pathnames were being incorrectly generated, and in
	the worst case, memory access violations were crashing the program.
	[Bug 119416, Patch 102972]

	******************************************************************

	*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000"             ***
	*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
	******************************************************************







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

>



3818
3819
3820
3821
3822
3823
3824






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































3825
3826
3827
3828
3829

	* tests/string.test (string-11.51):
	* generic/tclUtf.c (Tcl_UniCharCaseMatch):
	* generic/tclUtil.c (Tcl_StringCaseMatch): Fault with matching
	case-insensitive non-ASCII patterns containing upper case
	characters.  [Bug #233257]























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































	******************************************************************
	*** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001"             ***
	*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000"             ***
	*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
	******************************************************************
Added ChangeLog.2001.




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
2001-12-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/init.tcl: make sure env(COMSPEC) on Windows is executed
	with the right case, as it may otherwise fail inexplicably.

2001-12-28  Don Porter <dgp@users.sourceforge.net>

	* generic/tclCkalloc.c (MemoryCmd, TclFinalizeMemorySubsystem):
	Added the [memory onexit] command, intended to replace [checkmem].

	* doc/DumpActiveMemory.3: 
	* doc/memory.n: Updated documentation for [memory] and related
	matters.  [Bug 487677]

	* mac/tclMacBOAMain.c (Tcl_Main, CheckmemCmd): Removed all the
	machinery for the [checkmem] command that is completely duplicated
	by code in generic/tclCkalloc.c.

	* generic/tclBinary.c:
	* generic/tclListObj.c:
	* generic/tclObj.c:
	* generic/tclStringObj.c: Removed references to [checkmem] in
	comments, referencing [memory active] instead, since it is
	documented.

2001-12-28  Daniel Steffen <das@users.sourceforge.net>

	* mac/tclMacInit.c:
	* mac/tclMacTclCode.r: synced up tclInit features to unix/win:
	implemented TclSetPreInitScript support, use of existing tclInit 
	proc if defined, check of default encoding dir if set. Changed
	script library resource names to lowercase (i.e. same as
	corresponding files). Used Tcl_JoinPath instead of string append.
	Check that system encoding could be loaded before utf translating
	the LibraryPath.
	* mac/tclMacApplication.r:
	* mac/tclMacLibrary.r:
	* mac/tclMacOSA.r:
	* mac/tclMacResource.r: minor version resources cleanup

2001-12-21  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/tcl.m4 (SC_PATH_TCLCONFIG, SC_PATH_TKCONFIG):
	Search for config file using exec_prefix instead of
	prefix when no --with-tcl or --with-tk argument is used. [Bug 492418]

2001-12-21  Daniel Steffen <das@users.sourceforge.net>

	* unix/tcl.m4: fixed incorrect SHLIB_LD_LIBS
	setting for MacOSX / Darwin.
	* unix/configure: Regen.
	* unix/mkLinks.tcl: improved case-insensitive
	filesystem support.
	* unix/mkLinks: Regen.

2001-12-19  Don Porter <dgp@users.sourceforge.net>

	* unix/Makefile.in (dist): corrected use of eolFix.tcl on
	working files.  It should operate on distributed files.  [Bug 495120]

2001-12-19  David Gravereaux <davygrvy@pobox.com>

	* tools/tcl.wse.in: Fix for #495120.  tcl.wse.in was
	stored in cvs with improper <eol>.  This resulted in
	corrupted <eol> when checked-out on translating CVS
	clients such as windows (CRCRLF) and mac (CRCR).

2001-12-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure:
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Update
	SunOS 5.[0-6] target so that correct linker
	options are passed to gcc or ld. [Tk Bug 220863]

2001-12-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/README: Update to account for changes
	in the unix/dltest directory, the way autoconf
	is run, and the new "make shell" target.

2001-12-19  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Rename dltest to dlpkgs to
	fix problem where lib files were not getting
	built because dltest/ directory already existed.

2001-12-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinSerial.c (SerialCheckProc): corrected time
	calculations to be unsigned. (schroedter)

2001-12-18  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Define new dltest target that
	simply does a cd to dltest/ before running make.
	There is no need for the separate configure
	script that was previously being used.
	* unix/configure: Regen.
	* unix/configure.in: Subst into dltest/Makefile.
	* unix/dltest/Makefile.in: Define LIBS using
	DL_LIBS, LIBS, and MATH_LIBS variables instead
	of TCL_LIBS variable from tclConfig.sh.
	* unix/dltest/README: Update readme to account for new
	configure free implementation.
	* unix/dltest/configure: Removed.
	* unix/dltest/configure.in: Removed.

2001-12-18  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tcl.h (TCL_STUB_MAGIC): Added cast to force type to be
	an int and get rid of a persistent and pointless warning with
	SunPro compiler.

	* generic/tclCkalloc.c (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc): 
	* generic/tcl.decls (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc):
	Made the file parameters to these functions into CONST char *,
	like they always should have been to match the other Tcl*Db* API
	functions.

2001-12-17  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* Applied #219311 on behalf of Rolf Schroedter
	  <schroedter@users.sourceforge.net> to prevent fcopy on serial
	  ports from flooding the event queue.

2001-12-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/CrtInterp.3:
	* generic/tclBasic.c: docs and comments corrections [Bug 493412]
	Bug & patch by Don Porter.  

2001-12-14  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* win/tclWinNotify.c (Tcl_FinalizeNotifier): Stop Tcl on Windows
	from crashing when shutdown from a non-Tcl thread. Fixes Bug
	#217982 [orig. 5804] reported by Hugh Vu and Gene Leache.   I'm
	not convinced that the shutdown process is right even with this,
	but it was definitely wrong without...

2001-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* win/tclWinSock.c (TcpGetOptionProc): Fix for tcl bug item
	  #478565 reported by an unknown person. Bypasses all calls to
	  "gethostbyaddr" for address "0.0.0.0" to prevent delays on
	  Win/NT.

2001-12-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/Preserve.3: doc'd TCL_DYNAMIC use. [Patch #483989] (porter)

2001-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclIO.c (Tcl_GetsObj): Applied patch for bug #491341 as
	  provided by Don Porter <dgp@users.sourceforge.net>. Fixes the
	  assumption of having an empty Tcl_Obj to work with.

2001-12-11  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c:
	* generic/tclCompile.c:
	* generic/tclExecute.c: consistency patch, to make all
	  instructions that pop a variable number of Tcl_Obj's off the
	  execution stack take the number of popped objects as first
	  operand. Modified *only* the new instructions
	  INST_LIST_INDEX_MULTI and INST_LSET_FLAT, so this has no effect
	  on bytecodes generated up to tcl8.4a3 inclusive.

	* generic/tclExecute.c: fix debug messages in INST_LSET_LIST. 

	* generic/tclCompCmds.c (TclCompileLindexCmd):
	* generic/tclCompExpr.c (CompileMathFuncCall): removed the last
	  two overestimates of the necessary stack depth for bytecodes in
	  the fix of [Bug 483611].

2001-12-10  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* unix/tclUnixPipe.c (TclpCreateProcess): Applied Don Porter's
	  patch fixing bug #437489.

2001-12-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclEvent.c:
	* tests/event.test: fix background error reporting in the absence
	of a bgerror proc [Bug 219142].

2001-12-10  Don Porter <dgp@users.sourceforge.net>

	* doc/Access.3:
	* doc/CrtChannel.3:
	* doc/DString.3:
	* doc/ExprLong.3:
	* doc/FileSystem.3:
	* doc/GetStdChan.3:
	* doc/OpenFileChnl.3:
	* doc/StdChannels.3:
	* doc/TCL_MEM_DEBUG.3:
	* doc/Tcl_Main.3:
	* doc/Utf.3:
	* doc/file.n:
	* doc/tclsh.1:  Several typo and formatting corrections discovered
	during conversion to TMML.  Thanks to Joe English.  [Patch 490514]
	* unix/mkLinks: 'make mklinks'

2001-12-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c:
	* generic/tclCompExpr.c:
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclProc.c: fixed the calculation of the maximal stack
	depth required by bytecodes [Bug 483611].

2001-12-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: 
	* tests/trace.test: restored consistency in refCount accounting by
	array traces [Bug #4484339], submitted by Don Porter. 

2001-12-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/parseExpr.test, tests/for.test, tests/expr.test:
	* tests/expr-old.test, tests/compile.test, tests/compExpr.test
	* tests/compExpr-old.test: Kept up to date with syntax errors.
	* generic/tclParseExpr.c (ParsePrimaryExpr): Rewrote to give even
	better syntax errors in the fairly common case of an identifier
	without decorations by guessing based on the currently available
	functions.  Also made messages consistent between memdebug and
	ordinary builds.

2001-12-05  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: 
	* tests/trace.test: new algorithm for [array get], safe when there
	are traces that modify the array [Bug #449893]. 

2001-12-04  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/compExpr-old.test, tests/compExpr.test, tests/compile.test: 
	* tests/expr-old.test, tests/expr.test, tests/for.test: 
	* tests/while.test, tests/if.test: Rewrite to handle more specific
	syntax errors.
	* tests/parseExpr.test: Rewrite to get rid of dup test numbers and
	handle more specific syntax errors.
	* generic/tclParseExpr.c (LogSyntaxError): Added a detail message
	argument to help explain what the syntax error is.
	(Tcl_ParseExpr, ParseCondExpr, ParsePrimaryExpr): Added detail
	messages.
	(UNKNOWN_CHAR): New lexeme for characters that are always illegal
	in expressions outside strings.

2001-12-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/expr.n: Various documentation improvements in relation to
	the function calls.  Includes fix for Bug #487704 submitted by
	Devin Eyre.

2001-12-03  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc: Some install target bugs repaired along with
	$(TCLSTUBLIB) added to the dependencies rather than implicit through
	the dde and reg extensions which don't happen to always require it
	for some build types.

2001-11-30  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: Tcl_Preserve'ing VarTrace structures to avoid 
	memory corruption. Patch for [Bug: 484334] provided by Don Porter 

2001-11-29  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/namespace.test: modified namespace-41.2, added 41.3
	{knownbug} after discussion with Don Porter and Kevin Kenny.

2001-11-29  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/namespace.test: added namespace-41.2, a simpler test for
	[Bug: 231259]

2001-11-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclBinary.c (BINARY_SCAN_MAX_CACHE, Tcl_BinaryObjCmd,
	ScanNumber): Added caching scheme to reduce number of object
	allocations when doing scans of large repetitive binary strings.
	See comments in file for reasoning behind implementation.
	Suggested by Miguel Sofer in Patch #429916, but independently
	implemented.

2001-11-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/regsub.n, doc/regexp.n: Converted dangling references to
	METASYNTAX section into references to the re_syntax manual page.

2001-11-27  D. Richard Hipp   <drh@hwaci.com>

	* win/tclWinFCmd.c: Fix a coredump in the filename normalizer
	code for Win95/98.

2001-11-27  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc: Removed the Tk reference for the 'winhelp' target.
	Converge at install will need to be the solution for Tk and all other
	extensions.

2001-11-27  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdAH.test (cmdAH-24.2): Made test less sensitive to OS
	preemption, but perfection isn't practical [Bug 463189, reported
	by Don Porter.]

	* tests/switch.test (switch-9.*): Added tests to exercise more of
	the argument checking.  (switch-7.2,switch-7.3): Test changed
	behaviour slightly.
	* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reworked argument parsing
	to be stricter about what it accepts.  This should make uses of
	the [switch] command be more maintainable.  [Bug 475397, reported
	by Don Porter.]

2001-11-26  Don Porter <dgp@users.sourceforge.net>

	* generic/tclIntPlatDecls.h: 'make genstubs' after changes
	in 2001-11-23 commit from Daniel Steffen.

2001-11-24  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in: Add comments to better describe
	TCL_EXE and when it should be available.
	* win/Makefile.in: Add TCL_EXE variable to be used
	by rules like `make genstubs`. Don't set TCL_LIBRARY
	before running `make genstubs` since we will be running
	with a tclsh from the PATH not the one we build.

2001-11-24  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Add comctl32.lib
	to wish link libs. This change was originally added
	to Tk on 2001-11-09 but was not committed to Tcl.

2001-11-23  Daniel Steffen <das@users.sourceforge.net>

	* unix/Makefile.in:
	* unix/configure.in:
	* unix/install-sh:
	* unix/mkLinks:
	* unix/mkLinks.tcl:
	* unix/tclLoadDyld.c:
	* unix/tclMtherr.c: Mac OSX support: build system, dynamic code loading
	and support for case-insensitive filesystems in mkLinks (patch #435258)

2001-11-23  Daniel Steffen <das@users.sourceforge.net>

	Up-port to 8.4 of mac code changes for 8.3.3 & various new
	changes for 8.4, some already backported to 8.3.4 (patch #435658)

	* generic/tclObj.c: added #include to fix missing prototype errors

	* generic/tcl.h: MAC_TCL: addition of ConditionalMacros.h and use of
	DLLIMPORT and DLLEXPORT like on other platforms.  ( => no longer need
	the .exp files and can remove use of #pragma export that never worked
	well)
	removed line continuation in #if clause as this breaks the mac
	resource compiler (note that *.r files include tcl.h)

	* mac/tclMacFile.c: fixed bug in permission checking code

	* mac/tclMacLoad.c: corrected utf8 handling, comparison of
	package names to code fragment names changed to only match on the
	length of package name, this allows for fragment names with version
	numbers appended

	* mac/tclMacInt.h:
	* generic/tclInt.h:
	* mac/tclMacTime.c:
	* generic/tclIOUtil.c: moved declaration of TclpGetGMTOffset()

	* mac/tclMacShLib.exp:
	* mac/tclMacOSA.exp:
	* mac/tclMacMSLPrefix.h: removed files

	* unix/Makefile.in: removed reference to .exp files

	* mac/MW_TclBuildLibHeader.h:
	* mac/MW_TclBuildLibHeader.pch:
	* mac/MW_TclHeaderCommon.h:
	* mac/MW_TclStaticHeader.h:
	* mac/MW_TclStaticHeader.pch: new precompiled header files

	* mac/MW_TclAppleScriptHeader.pch:
	* mac/MW_TclHeader.pch:
	* mac/MW_TclTestHeader.pch:
	* mac/tclMacCommonPch.h: revised precompiled header handling: now
	include a common header file 'MW_TclHeaderCommon.h' from all .pch
	files, the .pch files themselves now only setup #defines (e.g.
	BUILD_tcl, STATIC_BUILD, TCL_DEBUG, TCL_THREADS) like in makefiles on
	other platforms.

	* mac/tclMac.h:
	* mac/tclMacPort.h:
	* mac/tclMacInt.h: use of BUILD_tcl and TCL_STORAGE_CLASS like on other
	platforms, standardize #include'd files to what's done on other
	platforms, removed use of #pragma export.

	* mac/tcltkMacBuildSupport.sea.hqx: new archive of mac build support
	files & suggested build environment directory hierarchy: 
	'Building MacTclTk' & 'CW Pro6 changes' readme's.
	projects for MoreFiles 1.5.2 static & shared libraries.
	project & sources for 'pseudoCarbonSupport', see below.
	included XML versions of the projects for CW Pro5 or Pro7 users.

	* mac/tclMacProjects.sea.hqx: updated mac build project files:
	build support for CodeWarrior Pro6, UnivIntf 3.4 & shared runtime
	libraries: the MSL libraries and MoreFiles are no longer compiled into
	Tcl.shlb, all non-static binaries now use the Pro6 shared runtime
	libraries and MoreFiles.shlb.  These shlbs are merged into the standard
	Wish and TclShell, but 3rd party applications linking with Tcl.shlb or
	Tk.shlb need to setup access to them.  (see the "(sh-ppc)" targets
	for how to do this.)
	included XML versions of the projects for CW Pro5 or Pro7 users.
	use compat/strtod.c instead of MSL's strtod()
	use WASTE versions of MSL for tcl test target to avoid text buffer
	cutoff at 32k.
	Merging the full MSL.shlb and the other shlbs into Wish & TclShell
	makes them a bit larger than before, use unmerged binaries to avoid
	copying the shared code with every application, e.g. when deploying
	numerous Wish based droplets.
	Note that using CW Pro5 to compile extensions is in principle still
	possible, but need to link with Pro6 runtime libraries.
	Tclapplescript now loads and runs on CFM68k.
	Highly experimental "pseudoCarbon" support for Tcl only on OS 8/9:
	binaries in "Build:(Carbon):" link against CarbonLib instead of
	InterfaceLib, however the actual code has not been carbonized! i.e. it
	will not run on OSX and may not even run properly with CarbonLib. 
	This should in principle allow you to build & test OS9 CFM Carbon
	binaries that need to link with Tcl.shlb.  On OSX you can use the
	native Tcl.framework, but you have to build a MachO binary as there
	is no CFM glue lib for Tcl.framework.
	the library pseudoCarbonSupport.shlb manually loads the symbols
	from InterfaceLib that are not in CarbonLib but are needed by the
	uncarbonized code in Tcl.shlb and TclShell.

	* generic/tclMain.c: MAC_TCL: workaround for broken/non-standard isatty
	on MW Pro6, #include <unistd.h> instead of defining isatty

	* mac/tclMacPort.h: MW Pro6 changes for MSL fcntl.h, stat.h & isatty

	* mac/tclMacAppInit.c: add EXTERN to InstallConsole to enable DLL
	export via the TCL_STORAGE_CLASS mechanism.

	* mac/tclMacFCmd.c: fix for FSpDirectoryCopy API change

	* mac/tclMacLibrary.c: emit compile time error when
	TCL_REGISTER_LIBRARY and USE_TCL_STUBS are both defined at the same
	time in an extension, this use is not currently supported and will
	result in a crash when dynamically loading the extension.

	* mac/tclMacApplication.r:
	* mac/tclMacLibrary.r:
	* mac/tclMacOSA.r:
	* mac/tclMacResource.r: fixed obsolete copyrights/dates in version
	strings; updated version strings to standard usage; added support for
	'(Support Libraries)' subfolder for shared runtime libraries in
	unmerged binaries; commented out demo setting of "Tcl Environment
	Variables"; reorganized resources among these files to avoid 
	multiple copies in applications and shared libraries, the script
	libraries are now no longer duplicated in Tclsh but are only included 
	in the resources of Tcl.shlb.

	* mac/tclMacChan.c:
	* mac/tclMacSock.c: cast for *BlockMode

	* mac/tclMacUtil.c:
	* mac/tclMacMath.h: removed obsolete hypot() definition

	* generic/tclIntPlatDecls.h:
	* generic/tclInt.decls:
	* generic/tclStubInit.c:
	* mac/tclMacNotify.c:
	* mac/tclMacOSA.c:
	* mac/tclMacUtil.c:
	* generic/tclThreadTest.c: renamed routines conflicting with standard
	Apple or MoreFiles headers (at compile or link time):
	GetGlobalMouse         -> GetGlobalMouseTcl
	FSpGetDirectoryID      -> FSpGetDirectoryIDTcl
	FSpOpenResFileCompat   -> FSpOpenResFileCompatTcl
	FSpCreateResFileCompat -> FSpCreateResFileCompatTcl
	NewThread              -> NewTestThread
	the renamed MoreFiles *Tcl routines are just wrappers calling into the
	MoreFiles DLL.

	* mac/tclMacCommonPch.h:
	* mac/tclMacThrd.c:
	* mac/tclMacPanic.c: removed OLDROUTINENAMES define, renamed obsolete
	apple API names to modern equivalents; UH3.4 support: added #include
	<ControlDefinitions.h>, updated New*Proc() calls to New*UPP().

	* mac/tclMacUnix.c: added missing (Tcl_Obj ***) cast to
	Tcl_ListObjGetElements call

	* mac/tclMacAlloc.c: modernized TclpSysAlloc() to use temporary
	memory instead of system heap memory when available (MacOS
	>= 7.5 and possibly earlier, use of system heap has been
	discouraged for a long time and has many disadvantages, e.g. memory
	isn't paged out, and errors can very easily bring the system down);
	fixed crashing bug in TclpSysRealloc() and CleanUpExitProc() where
	memory was being accessed after having been deallocated; fixed
	memory leak in (de)allocation code (for every block ever allocated
	with TclpSysAlloc, a Ptr was leaked), if temporary memory is
	available, don't track allocated memory, instead use
	RecoverHandle() to get Handle from Ptr, otherwise use doubly linked
	list to correctly track memory and free all allocated memory; added
	new option for ConfigureMemory: MEMORY_DONT_USE_TEMPMEM, disables
	use of temporary memory even when it would be available, only
	necessary when writing e.g. a driver (using tcl??); increased
	fraction of application heap reserved for OS routines to 512K

	* compat/strftime.c: 
	* mac/tclMacTime.c:
	* mac/tclMacPort.h:
	* generic/tclInt.decls: 
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: timezone support for mac via 
	TclpGetTZName() like on windows, using an inverse timezone table
	adapted from tclDate.c to map gmtoffset in seconds gotten from
	the MacOS APIs to a  timezone string, as there is no good way to get
	this info from MacOS. I had to make up some unusual timezones and
	arbitrarily decide on the most standard of the multiple choices
	available for every timezone.

	* generic/tclExecute.c: workaround for a MSL bug/misfeature: for
	very small floats, MSL can return errno ERANGE but a
	non-zero value ( < LDBL_MIN however)
	
	* mac/tclMacAppInit.c: support for WASTE text library using
	temporary memory, setting has no effect if WASTE is not used.
	
	* mac/tclMacPanic.c: removed duplicate code from generic/tclPanic.c
	and added that file to projects instead.

	* tests/all.tcl: set tcltest::singleProcess 1 as multiple processes
	are not available on the mac.
	
	* tests/cmdAH.test: access time not available on the mac, skip the 
	atime touch test
	
	* tests/appendComp.test:
	* tests/cmdMZ.test:
	* tests/compile.test:
	* tests/exec.test:
	* tests/fileName.test:
	* tests/lset.test:
	* tests/namespace.test:
	* tests/tcltest.test: added missing cleanups/tests/catches that
	caused tests to fail on the mac.

	* doc/tclvars.n: doc bug, env(PWD) should be env(HOME) [Bug 463834]
	
2001-11-21  Don Porter	<dgp@users.sourceforge.net>

	* tests/trace.test (trace-8.8): Corrected test for Bug 219393.

	* generic/tclBasic.c (Tcl_DeleteCommandFromToken,CallCommandTraces):
	* generic/tclCmdMZ>c (Tcl_UntraceCommand):  Added Tcl_Preserve and
	Tcl_Release calls to prevent deletion of CommandTrace structures
	until all callers are done using them, preventing memory corruption.
	[Bug 453805]

2001-11-20  Kevin B. Kenny  <kennykb@users.sourceforge.net>

	* doc/GetTime.3 (Tcl_GetTime):
	* generic/tcl.decls (Tcl_GetTime):
	* generic/tclClock.c (Tcl_ClockObjCmd):
	* generic/tclCompile.c (TclCleanupByteCode, TclInitByteCodeObj):
	* generic/tclCmdMZ.c (Tcl_TimeObjCmd):
	* generic/tclUtil.c (TclpGetTime):
	* generic/tclTest.c (GetTimesCmd):
	* generic/tclTimer.c (Tcl_CreateTimerHandler, TimerSetupProc,
	TimerCheckProc, TimerHandlerEventProc):
	* mac/tclMacNotify.c (Tcl_SetTimer):
	* mac/tclMacShLib.exp (Tcl_GetTime):
	* mac/tclMacTime.c (Tcl_GetTime):
	* unix/tclUnixChan.c (TclUnixWaitForFile):
	* unix/tclUnixEvent.c (Tcl_Sleep):
	* unix/tclUnixThrd.c (Tcl_ConditionWait):
	* unix/tclUnixTime.c (Tcl_GetTime):
	* win/tclWinNotify.c (Tcl_Sleep):
	* win/tclWinTest.c (TestwinclockCmd):
	* win/tclWinTime.c (TclpGetSeconds, TclpGetClicks, Tcl_GetTime):
	Changed all uses of TclpGetTime to Tcl_GetTime.  Added Tcl_GetTime
	to the Stubs table and the library documentation.  Added a
	TclpGetTime in tclUtil.c for backward compatibility of
	extensions. [Patch #483500, TIP#73]

	* generic/tclCmdMZ.c (Tcl_TimeObjCmd): Corrected an error in the
	[time] command that caused incorrect results to be returned if the
	total duration of all iterations exceeded 2**31 microseconds.
	[Bug #478847]

	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclStubInit.h: Reran 'make genstubs'
	
2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c
	* generic/tclCompile.h: 
	* generic/tclExecute.c: moving all code relative to bytecodes from
	tclBasic.c to tclExecute.c - the functions RecordTracebackInfo and
	Tcl_ExprObj went to tclExecute.c, and new interface function was
	defined (TclCompEvalObj).
	The final objective of this sequence of moves is to provide a
	clean, clear-cut interface between Tcl's core and the
	compiler/engine subsystem.  

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c
	* generic/tclCompile.h: 
	* generic/tclExecute.c: factoring out of common code in tclBasic.c
	(new function TclInterpReady defined: it resets the interp's
	result, then checks that it hasn't been deleted and that the
	nesting level is acceptable). Passed the responsibility of calling
	it to the *callers* of TclEvalObjvInternal.

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c
	* generic/tclExecute.c: a better variant of the previous-to-last
	commit (restoring numLevels computations). The managing of the
	levels now has to be done by the *callers* of TclEvalObjvInternal  

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: missing variable declaration under
	TCL_COMPILE_DEBUG. 

2001-11-20  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c:
	* generic/tclProc.c: restoring the computations of iPtr->numLevels
	to the original logic (previous to buggy modifs on 2001-11-16).

2001-11-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* tools/eolFix.tcl (new-file):
	* unix/Makefile.in: added EOL correction for Windows bat files to
	dist target. [Bug #219409] (davygrvy)

	* unix/tclUnixInit.c (TclpSetInitialEncodings): update of patch
	from 2001-11-16 that uses the old Tcl encoding check mechanism as
	a fallback to the original.  Also added a TCL_DEFAULT_ENCODING
	#define (defaults to iso8859-1).  Tcl will first try setlocale and
	nl_langinfo, and if that fails, guess based on certain LANG|LC_*
	env vars. [Patch #418645]

2001-11-19  David Gravereaux <davygrvy@pobox.com>

	* win/buildall.vc.bat:  Added useful comments.

2001-11-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/compile.test: added a test for bug [Bug 483309]

2001-11-19  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFile.c:
	* win/tclWinFCmd.c:
	* win/tclWin32Dll.c:
	* doc/file.n:
	* tests/winFCmd.test: improved speed of file normalization
	for Win95/98, and clarified docs on differences in file
	normalization between NT/2000 and the older operating systems.
	Added test to ensure normalization is correct.
	
2001-11-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c:
	* generic/tclParse.c: Code reorganisation. Moved all evaluation
	functions from tclParse.c to tclBasic.c, so that now tclParse.c
	deals exclusively with parsing and all evaluations are done by
	code in tclBasic.c. The functions moved are: TclEvalObjvInternal,
	Tcl_EvalObjv, Tcl_LogCommandInfo, Tcl_EvalTokensStandard,
	Tcl_EvalTokens, Tcl_EvalEx, Tcl_Eval, Tcl_EvalObj and
	Tcl_GlobalEvalObj. 

2001-11-19  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/trace.test (trace-8.8): Added adapted version of Bug
	#219393 as new test; the test won't reliably show up the old
	problem unless it is being run under something like Purify, but
	something is better than nothing...

	* generic/tclVar.c (Tcl_TraceVar2, Tcl_UntraceVar2): Added missing
	mask bits for trace result type and a check for a nonsense flag
	combination.
	* generic/tclCmdMZ.c (TraceVarProc): Added missing test for NULL
	when deleting a trace that doesn't cause an error.

	* doc/TraceVar.3: Added documentation for change due to TIP#68.

	* generic/tclCmdMZ.c (TraceVarInfo): Removed problematic errMsg
	field from structure.
	(TraceVarProc): Removed references to errMsg field and changed
	handling of errors so that they returned a Tcl_Obj* containing the
	error string.  This minimizes the number of calls to the memory
	management subsystem.
	(TclTraceCommandObjCmd, TraceCommandProc): Removed references to
	errMsg field which was never used in command traces in any case.
	(Tcl_TraceObjCmd, TclTraceVariableObjCmd): Removed references to
	errMsg field and made variable traces register with
	TCL_TRACE_RESULT_OBJECT bit set.

	* generic/tcl.h (TCL_TRACE_RESULT_DYNAMIC,TCL_TRACE_RESULT_OBJECT): 
	New constants to define how to handle the strings returned from
	trace callbacks [TIP#68]
	* generic/tclVar.c (CallTraces, Tcl_GetVar2Ex, TclGetIndexedScalar,
	TclGetElementOfIndexedArray, Tcl_SetVar2Ex, TclSetIndexedScalar,
	TclSetElementOfIndexedArray, Tcl_UnsetVar2, Tcl_ArrayObjCmd,
	TclDeleteVars, TclDeleteCompiledLocalVars, DeleteArray,
	TclVarTraceExists): Support for those new trace flags.

2001-11-19  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c: patch for [Bug 483309] (petasis).

2001-11-16  Kevin B. Kenny  <kennykb@users.sourceforge.net>

	* generic/tclListObj.c: removed a C++-style comment that
	  was inadvertently left in the source code.

2001-11-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/interp.test: 
	* generic/tclInterp.c (SlaveObjCmd): Corrected argument checking
	for '$interp alias|aliases|issafe'. [Patch #479560] (thoyts, hobbs)

	* unix/tclUnixInit.c: added HAVE_LANGINFO code block.
	* unix/configure: regened
	* unix/configure.in: added SC_ENABLE_LANGINFO call
	* unix/tcl.m4: made SHLIB_LD_LIBS='${LIBS}' for FreeBSD* (meyer)
	Added modified version of Wagner patch to make use of nl_langinfo
	where possible to determine Unix platform encoding, instead of the
	inflexible built-in system.  This is used by default when
	possible, and can be disabled with --enable-langinfo=no.
	[Patch #418645] (hobbs, wagner)

2001-11-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclObj.c: moved Tcl_GetCommandFromObj and all defining
	code for tclCmdNameType objects to tclObj.c (from tclExecute.c). 
	This code has nothing to do with bytecodes.

2001-11-16  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclParse.c:
	* generic/tclProc.c:
	* tests/stack.test: consolidation of duplicated code (in
	TclExecuteByteCode and EvalObjv); renaming of EvalObjv to
	TclEvalObjv as it is not static anymore; restored consistency of
	level counts between compiled and directly evaled code.
	[Bug 480896]

2001-11-12  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc:
	* win/rules.vc:  Small bug fixes.

	* win/README: added some docs pointing to the docs in makefile.vc
	for it's use.

2001-10-17  Kevin B. Kenny  <kennykb@users.sourceforge.net>

	* doc/lappend.n:
	* doc/lindex.n:
	* doc/linsert.n:
	* doc/list.n:
	* doc/llength.n:
	* doc/lrange.n:
	* doc/lsearch.n:
	* doc/lset.n (new-file):
	* doc/lsort.n:
	* generic/tclBasic.c (builtInCmds, Tcl_EvalObjEx):
	* generic/tclCmdIL.c (Tcl_LindexObjCmd, Tcl_LindexList):
	(Tcl_LindexFlat, Tcl_LsetObjCmd):
	* generic/tclCompCmds.c (Tcl_CompileLindexCmd, Tcl_CompileLsetCmd):
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c (TclExecuteByteCode):
	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclIntDecls.h:
	* generic/tclListObj.c (TclLsetList, TclLsetFlat, TclSetListElement):
	* generic/tclObj.c (TclInitObjSubsystem):
	* generic/tclStubInit.c:
	* generic/tclTestObj.c (TestobjCmd):
	* generic/tclUtil.c (TclGetIntForIndex, SetEndOffsetFromAny):
	* generic/tclVar.c (Tcl_LappendObjCmd):
	* tests/lindex.test:
	* tests/lset.test (new-file):
	* tests/lsetComp.test (new-file):
	* tests/obj.test:
	* tests/string.test:
	* tests/stringComp.test:
	Reference implementation of TIP's #22, #33 and #45.  Adds the
	ability of the [lindex] command to have multiple index arguments,
	and adds the [lset] command.  Both commands are byte-code compiled.
	[Patch #471874] (work by Kenny, commited by Hobbs)

2001-11-12  David Gravereaux <davygrvy@pobox.com>

	* win/buildall.vc.bat(new):
	* win/makefile.vc:  Small fix with deriving the "OriginalFilename"
	string in the .rc scripts.  Added a quick batchfile for building
	the entire thing.

2001-11-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/FileSystem.3:
	* doc/file.n:
	* doc/tcltest.n: converted use of \' to more reasonable format.

2001-11-10  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in: Add "make gdb" target. This target
	can run tclsh inside either gdb or insight.

2001-11-10  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc:  Added a check to make sure one runs the makefile
	from the /win directory only.

	* win/mkd.bat:
	* win/rmd.bat:  Changes from Llyod Lim for better stability.
	[Patch #456759]

2001-11-09  David Gravereaux <davygrvy@pobox.com>

	* win/makefile.vc:
	* win/tcl.dsp:  winhelp target fixes for non-NT systems.  It
	seems NMAKE under these remembers changed directories during
	commands.   A new tcltest feature from Peter Spjuth 
	<peter.spjuth@space.se> to specify a pattern file from the
	commandline and redirecting output to a file when not under
	NT with it's scrollback console.  Then it replays it, piped
	through more.  Added 2 new static "configurations" to tcl.dsp.
	I could keep adding more, but I think we should leave it up to
	the user for customizing it.

	Sticky-points left:  'profile' option.

2001-11-09  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/FileSystem.3:
	* doc/StdChannels.3:
	* doc/file.n:
	* doc/tcltest.n:
	* tools/man2help.tcl: 
	* tools/man2help2.tcl: fixed winhelp generation problems
	[Patch #480268]

	* unix/configure:
	* unix/tcl.m4: added -lc to AIX libs, fixed path to ldAix

2001-11-09  Don Porter	<dgp@users.sourceforge.net>

	* tests/var.test:
	* generic/tclVar.c: Corrected bug in [global] when dealing
	with variable names matching :*.  [Bug 480176]

2001-11-08  Mo DeJong  <mdejong@users.sourceforge.net>

	Fixup stack size under OSF1. [Tcl patch 474790]

	* unix/configure: Regen.
	* unix/tcl.m4: Add HAVE_PTHREAD_ATTR_SETSTACKSIZE define
	to EXTRA_CFLAGS to adjust initial stack size.

2001-11-08  Mo DeJong  <mdejong@users.sourceforge.net>

	Enable thread support under FreeBSD. [Tcl bug 473708]

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_ENABLE_THREADS): Check for pthread functions
	in libc_r and enable thread support if found.
	* unix/dltest/Makefile.in: Set SHLIB_LD_LIBS and use it in
	the Makefile to properly link a shared library.

2001-11-08  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* unix/dltest/Makefile.in:
	Avoid adding libc to the LIBS variable since it
	is not needed when linking with CC. If required
	when linking with LD it should be done on a case
	by case basis in tcl.m4.

2001-11-08  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc:
	* win/makefile.vc:  Fixed install target to adjust for the
	different build types.  Added a 'linkexten' option to link the
	win extensions inside the shell when built static.  Placed
	win/tclAppInit.c patch in SF patch DB for approval. 'profile'
	option not hooked in yet.  Everything else know is done.

	* win/tcl.dsp(new):
	* win/tcl.dsw(new):  Simple MsDev stub project files that calls
	makefile.vc.  Will help run Tcl in the debugger easier without
	confusing MsDev for where the .pdb files are.

2001-11-07  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in:
	Print a message indicating that the user should
	run "make genstubs" when the generated tclStubInit.c
	file is out of date. We can't regenerate automatically
	since there may be no tclsh on the system and that
	would cause bootstrap problems. [Tcl bug 465874]

2001-11-07  Mo DeJong  <mdejong@users.sourceforge.net>

	Define TCL_INCLUDE_SPEC in tclConfig.sh. It should be
	included by extensions that need to find Tcl include
	headers in the install location. The user can override
	the include install dir with --includedir so we need
	to record this information for extensions. [Tcl bug 421835]
	
	* unix/configure: Regen.
	* unix/configure.in: Define TCL_INCLUDE_SPEC.
	* unix/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.
	* win/configure: Regen.
	* win/configure.in: Define TCL_INCLUDE_SPEC.
	* win/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.

2001-11-07  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc:
	* win/makefile.vc: Dropped the NOMSVCRT macro and put it on the
	option list instead.  It makes more sense to me this way as
	NOMSVCRT=0 would only be the valid setting.  Fixed the dde and reg
	extension for building static.  Improved, but not perfected, the
	winhelp target.

2001-11-07  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/README: Change minimum VC++ version to 5.X since
	4.X is known not to work.
	Indicate that Mingw is required and building with Cygwin
	gcc is not supported. Include instructions that indicate
	how to install Mingw and what URLs folks should use to
	download the supported version of Mingw.
	* win/configure: Regen.
	* win/configure.in: Error out if user tries to compile the
	Windows version of Tcl with Cygwin gcc. Users should compile
	with Mingw gcc instead.

2001-11-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclIO.c (ReadChars): Fixed bug #478856 reported by
	  Stuart Cassoff <stwo@users.sourceforge.net>. The bug caused loss
	  of fileevents when [read]ing less data from the channel than
	  buffered. Due to an empty input buffer the flag
	  CHANNEL_NEED_MORE_DATA was set but never reset, causing the I/O
	  system to wait for more data instead of using a timer to
	  synthesize fileevents and to flush the pending data out of the
	  buffers.

2001-11-06  David Gravereaux <davygrvy@pobox.com>

	* win/rules.vc (new):
	* win/makefile.vc:  Complete over/under rewrite to support numerous
	build options all from the commandline itself without needing to
	edit the makefile.  Now requires vcvars32.bat to be run prior to
	running nmake for bootstraping the environment.  Fully doc'd usage
	for it is in makefile.vc.  Commentary welcome.  Sticky points left
	are:

	1) winhelp target shows errors in the converting script.
	2) .rc scripts aren't getting the right #defines to build the correct
	   "OriginalFilename" strings. (have patch, won't commit yet)
	3) Naming convention with suffixes describing the buildtype are 'tsdx'
	   which will need public acceptance. ie. tclsh84tsx.exe is a (t)
	   threaded shell (s) statically linked to the core and (x) uses
	   msvcrt instead of libcmt.

2001-11-04  Vince Darley  <vincentdarley@users.sourceforge.net>

	* library/init.tcl: made filesystem fallback proc
	::tcl::CopyDirectory more robust to vagaries of non-native
	filesystems.
	
2001-11-02  Vince Darley  <vincentdarley@users.sourceforge.net>

	* doc/file.n:
	* generic/tclIOUtil.c: updated documentation and comments
	to clarify behaviour of 'file copy' wrt soft links.
	
2001-10-29  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFile.c: fix to '-types {f r}' bug in
	TclpMatchInDirectory (which could cause a UMR, as well as
	returning wrong results).  Also improved API for 'stat'
	to resolve [Bug#219258].
	* win/tclWin32Dll.c
	* win/tclWinInt.h: addition of improved stat API to internal 
	lookup table.
	* tests/fileName.test: two new tests for the above bug.
	* generic/tclIOUtil.c: some cleanup of comments and #ifdefs
	
2001-10-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tclUnixFile.c (TclpMatchInDirectory): Argument to access()
	was entryPtr->d_name instead of nativeEntry which failed when
	trying to check access for files in other than the current
	directory. [Bug 475941, reported by Georgios Petasis]

2001-10-25  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* unix/tclUnixChan.c: Added stateUpdated member to struct TtyState.
	(TtyCloseProc,TtySetOptionProc,TtyInit): Use stateUpdated member
	of TtyState to decide whether it is necessary to reset a serial
	port when Tcl closes it.  Blindly resetting can cause Tcl to be
	sent an unexpected SIGTSTP when it is executing in the background
	[Bug 471374, reported by Chris Nelson]

2001-10-22  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* doc/ObjectType.3: Minor documentation fix, reported by David
	  N. Welton <davidw@users.sourceforge.net> directly to me.

2001-10-22  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFCmd.c: fix to stop test suite from hanging process
	under some versions of WinNT. [Bug #466102] (Kevin Kenny)
	
2001-10-18  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/clock.test (clock-8.1): 
	* generic/tclDate.c (RelativeMonth): 
	* generic/tclGetDate.y (RelativeMonth): corrected off-by-one-day
	error in clock scan with relative months and years during swing
	hours. [Bug #413397, Patch #414024] (lavana)

2001-10-18  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c: fix to bug in Tcl_FSChdir shown up
	by recent tclkit builds.

2001-10-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/tclUnixPipe.c (PipeInputProc, PipeOutputProc): do immediate
	retry when error is returned with errno == EINTR.
	[Bug #415131] (leger)

2001-10-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/tclLoadAout.c (TclGuessPackageName): removed unused vars
	and fixed warnings. [Bug #446622] (lim)

2001-10-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclProc.c: changing a memcmp to strncmp to avoid a memory
	error detected by purify (thanks Jeff); modify style to agrre with
	the style guide. 
	
2001-10-15  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclInt.decls (TclExpandCodeArray,TclGetInstructionTable):
	  Added to internal stubs table. Tclcompiler (Tclpro project)
	  needs them if used as loadable package under Windows. Changed
	  signatures. We don't want to describe compiler internal
	  structures in "tclInt.h".

	* generic/tclCompile.h: S.a. Removed function declarations.
	* generic/tclCompile.c: S.a. Adapted to changed signatures.

2001-10-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/configure: 
	* unix/configure.in: 
	* win/configure: 
	* win/configure.in: 
	* win/tcl.m4: reworked to be a little cleaner in comparison to
	each other, and to AC_SUBST even empty vars for win/tclConfig.sh

	* generic/tclFileName.c: minor code cleanup

	* generic/tcl.h: moved #define of WIN32 to tcl.h where __WIN32__
	is defined and added #ifndef check.

	* doc/open.n: moved all fconfigure option docs to fconfigure.n
	* doc/fconfigure.n: added serial config options

	* win/tclWinChan.c:
	* win/tclWinPort.h:
	* win/tclWinSerial.c: added TIP #35 Windows enhancements for
	serial configuration. [Patch #438509] (schroedter)

2001-10-15  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclFCmd.c: fix to memory leak in TclFileDeleteCmd on
	certain error conditions.
	* doc/FileSystem.3: fix to typo.
	
2001-10-12  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/encoding/ebcdic.enc:
	* tools/encoding/ebcdic.txt: EBCDIC charset mapping.
	[Patch #219323] (nijtmans)

	* library/encoding/tis-620.enc:
	* tools/encoding/tis-620.txt: TIS-620 charset mapping.
	[Patch #467423] (poonlap)

	* tests/http.test: added removeFile for outdata

	* tests/ioCmd.test: added catch around file removal, as Windows
	file locking throws errors.

	* tests/socket.test (socket-7.2): corrected to work on Win2K.

2001-10-12  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* tests/compile.test: new tests for [Bug 467523]; they are only
	effective if TCL_MEM_DEBUG was set during compilation.

2001-10-11  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclLiteral.c (TclReleaseLiteral): insured that
	self-referential bytecodes are properly cleaned up on interpreter
	deletion [Bug 467523] (Ronnie Brunner)

2001-10-10  David Gravereaux  <davygrvy@pobox.com>

	* win/tclWinPort.h:  #include <winsock2.h> needed to get moved
	to after #include <windows.h> or wierd misunderstandings took
	place when -D_WIN32_WINNT=0x0400 is set for outside code that
	requires knowledge of Tcl innards.  General header macro magic
	applied liberally...

2001-10-10  Don Porter	<dgp@users.sourceforge.net>

	* tests/unixInit.test:	Corrected restore of ::env(LANG).

2001-10-09  Jeff Hobbs	<jeffh@ActiveState.com>

	* generic/tclFileName.c (Tcl_SplitPath): corrected mem leak
	intro'd with VFS code where the result obj from Tcl_FSSplitPath
	was not getting freed.

2001-10-09  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclLiteral.c: (TclReleaseLiteral) reverted previous
	patch for [Bug 467523] - cure is worse than the illness.

2001-10-05  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclLiteral.c: (TclReleaseLiteral) insured that
	self-referential bytecodes are properly cleaned up on interpreter
	deletion [Bug 467523] (Ronnie Brunner)

2001-10-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* tools/configure:
	* tools/configure.in: noted 8.4 as default Tcl version

	* library/encoding/cp936.enc:
	* library/encoding/cp949.enc:
	* library/encoding/cp950.enc:
	* library/encoding/iso8859-16.enc:
	* library/encoding/macCroatian.enc:
	* library/encoding/macCyrillic.enc:
	* library/encoding/macGreek.enc:
	* library/encoding/macIceland.enc:
	* library/encoding/macRoman.enc:
	* library/encoding/macTurkish.enc:
	* tools/encoding/cp1250.txt:
	* tools/encoding/cp1251.txt:
	* tools/encoding/cp1252.txt:
	* tools/encoding/cp1253.txt:
	* tools/encoding/cp1254.txt:
	* tools/encoding/cp1255.txt:
	* tools/encoding/cp1256.txt:
	* tools/encoding/cp1257.txt:
	* tools/encoding/cp1258.txt:
	* tools/encoding/cp874.txt:
	* tools/encoding/cp932.txt:
	* tools/encoding/cp936.txt:
	* tools/encoding/cp949.txt:
	* tools/encoding/cp950.txt:
	* tools/encoding/iso8859-1.txt:
	* tools/encoding/iso8859-10.txt:
	* tools/encoding/iso8859-13.txt:
	* tools/encoding/iso8859-14.txt:
	* tools/encoding/iso8859-15.txt:
	* tools/encoding/iso8859-16.txt:
	* tools/encoding/iso8859-2.txt:
	* tools/encoding/iso8859-3.txt:
	* tools/encoding/iso8859-4.txt:
	* tools/encoding/iso8859-5.txt:
	* tools/encoding/iso8859-6.txt:
	* tools/encoding/iso8859-7.txt:
	* tools/encoding/iso8859-8.txt:
	* tools/encoding/iso8859-9.txt:
	* tools/encoding/koi8-r.txt:
	* tools/encoding/macCentEuro.txt:
	* tools/encoding/macCroatian.txt:
	* tools/encoding/macCyrillic.txt:
	* tools/encoding/macGreek.txt:
	* tools/encoding/macIceland.txt:
	* tools/encoding/macRoman.txt:
	* tools/encoding/macTurkish.txt:
	Updated encodings with latest mappings from www.unicode.org.  This
	did not include some Mac encodings that have special multi-unichar
	translations now (like symbols, dingbats and japanese).  Also does
	not include big5, gb or euc* as those have different formats in
	the latest Unicode version that need new conversion tools.  Not
	all related .enc files changed as some had been updates separately.

2001-10-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclEvent.c (Tcl_FinalizeThread): moved freeing of
	tclLibraryPath to before the thread exit handlers are called.
	Slight modification to change on 2001-09-24.

2001-10-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/configure: regen'ed
	* win/tcl.m4:
	* win/makefile.vc: added Win64 SDK RC1 compilation support
	* win/Makefile.in: added $(LDFLAGS_CONSOLE) to TCLSH, TCLTEST and
	PIPE_DLL_FILE targets to get the link flags

	* win/tclWinInit.c: minor 64bit casts

2001-10-01  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCmdIL.c:
	* generic/tclCmdMZ.c:
	* generic/tclParseExpr.c: removed unnecessary inclusion of
	tclCompile.h and made a small modification in (InfoBodyCmd) to
	improve the isolation of the compiler/engine subsystem.

2001-09-29  Vince Darley  <vincentdarley@users.sourceforge.net>

	* generic/tclIOUtil.c:
	* doc/FileSystem.3: corrected and clarified documentation
	for 'Tcl_FSListVolumes(Proc)'.  No code changes.
	
2001-09-28  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/FindExec.3: added a comment not to change the working
	directory before calling Tcl_GetNameOfExecutable [Bug 219215] 

2001-09-28  Kevin Kenny   <kennykb@users.sourceforge.net>

	* generic/tclIO.c: added two more '(ClientData)' casts
	on calls to Tcl_Preserve and Tcl_Release -- ones that
	Vince apparently missed.
	
2001-09-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/lsort.n: Improved doc...
	* generic/tclCmdIL.c (Tcl_LsortObjCmd, SortCompare): Made
	offset-from-end indexing work, and factored out some "magic
	numbers" for easier understanding.  [Bug #465674]
	* tests/cmdIL.test (cmdIL-1.26): Added test for offset-from-end
	indexing for lsort.

2001-09-28  Vince Darley  <vincentdarley@users.sourceforge.net>

	* win/tclWinFCmd.c:
	* unix/tclUnixFCmd.c: fix to performance issue reported
	by jcw in which 'access("")' is called unnecessarily when
	normalizing any absolute path.
	* generic/tclIO.c: added '(ClientData)' cast to calls to
	Tcl_(Preserve|Release) newly introduced, fixing compile
	error on Windows.
	
2001-09-27  Don Porter  <dgp@users.sourceforge.net>

	* doc/FileSystem.3 (Tcl_FSLoadFile):
	* generic/tcl.decls (Tcl_FSLoadFile):
	* generic/tcl.h (Tcl_FSLoadFileProc):
	* generic/tclInt.h (TclpLoadFile):
	* generic/tclIOUtil.c (Tcl_FSLoadFile):
	* generic/tclLoadNone.c (TclpLoadFile):
	* generic/tclTest.c (TestReportLoadFile):
	* library/ldAout.tcl:
	* mac/tclMacLoad.c (TclpLoadFile):
	* unix/tclLoadAix.c (TclpLoadFile):
	* unix/tclLoadAout.c (TclpLoadFile):
	* unix/tclLoadDl.c (TclpLoadFile):
	* unix/tclLoadDld.c (TclpLoadFile):
	* unix/tclLoadDyld.c (TclpLoadFile):
	* unix/tclLoadNext.c (TclpLoadFile):
	* unix/tclLoadOSF.c (TclpLoadFile):
	* unix/tclLoadShl.c (TclpLoadFile):
	* win/tclWinLoad.c (TclpLoadFile):
	* win/tclWinFCmd.c (DoRemoveJustDirectory):  More CONST poisoning
	fixes from the 2001-09-24 TIP 27 changes.  CONST-ified
	Tcl_FSLoadFile and TclpLoadFile.  Report and patch from Kevin
	Kenny. [Bug 465833]

	* generic/tclIO.c (ChannelTimerProc):  Added Tcl_Preserve()
	and Tcl_Release() to fix segfault introduced by the 2001-09-26
	changes.  [Bug 465494]

	* doc/TCL_MEM_DEBUG.3:  Updated out-of-date reference to
	#define GUARD_SIZE.

	* doc/UpVar.3 (Tcl_UpVar,Tcl_UpVar2):
	* generic/tcl.decls (Tcl_UpVar,Tcl_UpVar2):
	* generic/tclInt.decls (TclFindProc,TclGetFrame):
	* generic/tclInt.h (TclFindProc,TclGetFrame,TclLookupVar,
	  TclPrecTraceProc,TclProcInterpProc}):
	* generic/tclProc.c (TclGetFrame,TclFindProc):
	* generic/tclVar.c (Tcl_UpVar,Tcl_UpVar2,MakeUpvar):  Updated APIs in
	generic/tclProc.c and generic/tclVar.c according to the guidelines
	of TIP 27.  [Patch 465442]

	* generic/tclDecls.h:
	* generic/tclIntDecls.h: make genstubs

2001-09-26  Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* doc/fileevent.n: Accepted [Patch #465279] adding an example to
	  the fileevent manpage. Minor modifications to get a better
	  formatting. Report and patch by David N. Welton
	  <davidw@users.sourceforge.net>.

	* The changes below fix [Bug #462317] where Expect tried to read
	  more than was in the buffers and then blocked in the OS call as
	  its pty channel driver provides no blockmodeproc through which
	  the OS could be notified of blocking-behaviour. Because of this
	  the general I/O core has to take more care than usual to
	  preserve the semantics of non-blocking channels.

	  The problem was reported by "Kevin O'Gorman"
	  <kevin@kosmanor.com>.

	* generic/tclIO.c (Tcl_ReadRaw): Do not read from the driver if
	  the channel is non-blocking and the fileevent causing the read
	  was generated by a timer. We do not know if there is data
	  available from the OS. Instead of going to the OS for more and
	  potentially blocking we simply signal EWOULDBLOCK to the higher
	  levels to cause the system to wait for true fileevents.
	  (GetInput): Same as before.
	  (ChannelTimerProc): Added set and clear of CHANNEL_TIMER_FEV.

	* generic/tclIO.h (CHANNEL_TIMER_FEV): New flag for channels. Is
	  set if a fileevent was generated by a timer, the channel is not
	  blocking and the driver did not provide a blockmodeproc. In that
	  case the I/O core has to be especially careful about going to
	  the driver for more data.

2001-09-26  Don Porter  <dgp@users.sourceforge.net>

	* doc/SplitPath.3 (Tcl_GetPathType):
	* generic/tcl.decls (Tcl_GetPathType):
	* generic/tclFileName.c (Tcl_GetPathType):
	* win/tclWinFile.c (TclpMatchInDirectory, NativeStat):  Vince
	Darley reports the 2001-09-24 TIP 27 changes left the win
	directory CONST poisoned.  These changes should fix that.

	* generic/tclDecls.h: make genstubs

2001-09-25  Don Porter  <dgp@users.sourceforge.net>

	* doc/GetInt.3:
	* generic/tclInt.h (TclGetLong deleted):
	* generic/tcl.decls:
	* generic/tclInt.decls:
	* generic/tclGet.c:  Updated APIs in generic/tclGet.c
	according to the guidelines of TIP 27.  [Patch 464674]

	* generic/tclDecls.h: 
	* generic/tclIntDecls.h: make genstubs

2001-09-25  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: removed comments referring to unused flag
	TCL_PARSE_PART1. 
	
2001-09-24  Don Porter  <dgp@users.sourceforge.net>

	* doc/Concat.3:
	* doc/DString.3:
	* doc/SplitList.3:
	* generic/tclInt.h (TclCheckBadOctal):
	* generic/tcl.decls:
	* generic/tclInt.decls:
	* generic/tclEncoding.c (OpenEncodingFile):
	* generic/tclMain.c (Tcl_Main):
	* generic/tclUtil.c:
	* unix/tclLoadDl.c (TclpLoadFile):  Updated APIs in 
	generic/tclUtil.c according to the guidelines of TIP 27.
	[Patch 464553]

	* generic/tclDecls.h: 
	* generic/tclIntDecls.h: make genstubs

2001-09-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* The change below fixes [Bug #464380]. The bug was reported by
	  Ronnie Brunner <rbrunner@users.sourceforge.net>. He also
	  provided the patch.
	
	* generic/tclEvent.c (Tcl_Finalize): Moved release of
	  'tclLibraryPath' to Tcl_FinalizeThread.
	  (Tcl_FinalizeThread): See above, new place for release of
	  'tclLibraryPath'.

2001-09-24  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tools/encoding/cp1252.txt: File was missing part of the encoding
	  [euro, ZCaron and zcaron].

	* doc/OpenFileChnl.3: Add docs for Tcl_OutputBuffered; remove some
	  old changebars.

2001-09-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclExecute.c (TclExecuteByteCode): corrected
	  INST_STR_CMP else case for strings to pass true utf char length
	  to Tcl_UtfNCmp.

2001-09-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinInit.c: added extra processor definitions. (mstacy)

	* win/tclWinSock.c (SocketThread): corrected pointer cast for _WIN64.

	* win/tclWinNotify.c: removed unnecessary winsock include (it is
	  already in from tclWinPort.h).

	* win/tclWinPort.h: changed winsock.h include to winsock2.h.
	  Reverses change from 2000-11-16, but is necessary for WIN64.
	  Extensions should comply with defined OS words, or use #ifndef.

2001-09-20  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/socket.test: removed dependence on being run from same dir
	  as remote.tcl, which only now needs to be in the same dir as
	  this file.  [Bug #219326]

2001-09-19  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclTest.c (TestcmdtokenCmd): corrected pointer
	  storage/retrieval for 64bit machines.

	* generic/tclCmdAH.c (Tcl_FormatObjCmd):
	* generic/tclScan.c (Tcl_ScanObjCmd): corrected handling of format
	and scan on 64-bit machines. [Bug #412696] (rmax)

	* unix/configure: regen'ed
	* unix/tcl.m4: added --enable-64bit support for HP-11 with the
	64-bit kernel.

	* tests/basic.test:
	* tests/cmdInfo.test: improved skip reporting of missing commands

	* tests/winFCmd.test: simplified error check for winFCmd-7.9

	* tests/winPipe.test: removed obsolete cat16 tests

	* generic/tclExecute.c (TclExecuteByteCode): fixed invalid usage
	of valuePtr in TRACE_WITH_OBJ in INST_EVAL_STK case. [Bug #462594]
	Changed INST_STR_CMP instruction to promote to Unicode strings
	only when one of the strings is already of Unicode type.

	* generic/tclExecute.c (TclExecuteByteCode):
	* generic/tclCompile.c (instructionTable):
	* generic/tclCompCmds.c (TclCompileStringCmd): INST_STR_MATCH -
	Updated to Int1 instruction type and added special case to use
	INST_STR_EQ instead when no glob chars are specified in a static
	string.

	* tests/{for.test,foreach.test,if.test,while.test}:
	* generic/tclCompCmds.c (TclCompileForCmd, TclCompileForeachCmd,
	TclCompileIfCmd, TclCompileWhileCmd): Corrected the overaggressive
	compiling of loop bodies enclosed in ""s.  [Bug #219166] (msofer)

2001-09-19  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclExecute.c: insured that execution stack errors are
	also detected at abnormal returns.

2001-09-19  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/socket.n: Added documentation to mention what happens when a
	server socket is created with port=0.  Removed an old change bar,
	and no new change bar because Tcl has always behaved this way as
	it is really a poorly-documented standards-defined OS feature.

	* tests/util.test (util-8.1): Test derived from code to detect the
	problem, but the test always works in the C locale, so beware if
	you are maintaining the code.
	* generic/tclUtil.c (TclNeedSpace): Rewrote to be UTF-8 aware.
	[Bug 411825, but not that patch which would have added extra
	spaces if there was a real non-ASCII space involved. ]

2001-09-18 Andreas Kupries  <andreas_kupries@users.sourceforge.net> 

	* generic/tclIOCmd.c (Tcl_PutsObjCmd): Rewritten to have saner and
	  faster argument handling.  Fixes bug #123552. Patch provided by
	  Donal K. Fellows <fellowsd@cs.man.ac.uk>: #402564.

2001-09-18  Don Porter  <dgp@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): On Linux, disable inlining when
	one of the compat/*.c routines is to be linked in. [Patch 440891]

2001-09-17  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tcl.h: removed forced #define USE_TCLALLOC 1 for
	Windows.  This means the native system allocator will be used by
	default.  This should be binary and source compatible with
	extensions, as Tcl_Alloc is a properly stubbed function.

2001-09-17  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* generic/tclExecute.c: corrected small bug in [Patch 456668] -
	the varFramePtr was not restored in one possible exit.

2001-09-17  Miguel Sofer  <msofer@users.sourceforge.net>
	
	* doc/tclvars.n:
	* generic/tclCompile.c:
	* generic/tclCompile.h:
	* generic/tclExecute.c:
	* generic/tclProc.c: disabled all compile and execution tracing
	functionality in standard builds; TCL_COMPILE_DEBUG is now
	necessary to enable it. [Bug 451858]

2001-09-14  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* doc/gets.n: 
	* doc/read.n: 
	* doc/puts.n: 
	* doc/flush.n: 
	* doc/fconfigure.n: 
	* doc/flush.n: 
	* doc/eof.n: 
	* doc/seek.n: 
	* doc/tell.n: 
	* doc/close.n: 
	* doc/fileevent.n: Added references to the Tcl standard
	  channels. Item [219250], reported by David LeBlanc
	  <whisper@oz.net>. Thanks to Christopher Nelson
	  <chris@pinebush.com> for doing editorial work.

2001-09-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* win/Makefile.in:
	* win/configure.in:
	* win/makefile.bc:
	* win/makefile.vc:
	* library/dde/pkgIndex.tcl: Fixed version numbers from bogus tcl
	  versions to independent versions for dde and registry packages.

2001-09-13  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/regexp.test (regexp-20.1):
	* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): had to adjust fix from
	2001-08-06 to actually duplicate the objects in certain cases.
	This is really a place where feather would have been essential.
	[Bug #461322]

	* generic/tclUtf.c (Tcl_UtfPrev): corrected to return the proper
	location when the middle of a UTF-8 byte was passed in.
	[Tk Bug #450504]

	* ChangeLog.1999:
	* ChangeLog: broke changes from 199x into ChangeLog.1999 to reduce
	  size of the main ChangeLog.

2001-09-13  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* tests/ioCmd.test: Changed the computation of the result for
	  iocmd-8.1[123] so that the tests work for single- and
	  multi-process execution of the testsuite. Depending on the
	  choice of the user stdout is a tty or not and thus reports
	  different channel options. Fixes [460993] reported by Don
	  Porter.

2001-09-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* doc/ParseCmd.3:  
	* generic/tcl.decls:
	* generic/tclCmdMZ.c (Tcl_SubstObjCmd):
	* generic/tclDecls.h:
	* generic/tclParse.c:
	* generic/tclStubInit.c:
	* tests/parse.test: Deprecate the use of Tcl_EvalTokens, replaced
	by the new Tcl_EvalTokensStandard. The new function performs the
	same duties but adheres to the standard return convention for Tcl
	evaluations; the deprecated function could only return TCL_OK or
	TCL_ERROR, which caused [Bug 219384] and [Bug 455151].
	This patch implements [TIP 56].
	
2001-09-12  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4: Invert the logic that checks for $GCC.
	Instead of checking for "$GCC" = "no" we check for
	"$GCC" != "yes" or simply swap the true and false
	blocks of code in an if statement. That way if
	GCC is set to "" everything will still work. [Bug 460991]

2001-09-12  Don Porter <msofer@users.sourceforge.net>

	* tests/appendComp.test:
	* tests/lsearch.test:
	* tests/namespace.test:
	* tests/rename.test:
	* tests/split.test:  Corrected tests to better isolate tests in
	one file from influencing tests in other files.  [Bug 460591]

2001-09-12  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tcl.decls: reserved stub #481 for the implementation of
	[TIP 56]

2001-09-11  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* doc/OpenFileChnl.3: Added documentation for Tcl_WriteRaw and
	  Tcl_ReadRaw [#414929].
	
	* doc/CrtChannel.3: Added documentation for Tcl_ChannelBuffered
	  and Tcl_GetTopChannel [#414929].

	* The changes below are a fix for [219253].

	* tests/socket.test: Removed _most_ instances of hardwired port
	  numbers for listening sockets. Remaining are the ports in all
	  tests with constraint 'doTestsWithRemoteServer'. These seem to
	  be designed for a more controlled environment and are usually
	  skipped when running the testsuite.

	* tests/io.test: Removed all instances of hardwired port numbers
	  for listening sockets.

2001-09-10  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclEvent.c (TclInExit): Corrected handling of tsd in
	late stages of finalization.  [Bug #419449] (darley)

	* tests/stack.test:
	* generic/tclInterp.c (AliasObjCmd): Check the numLevels to ensure
	that we aren't hitting some alias loop condition.  [Bug #443184]

2001-09-10  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/configure: Regen.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Don't include . characters
	in the Tcl library name when building on FreeBSD 3.X and later
	systems. [Patch 450725]

2001-09-10  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* doc/tclsh.1:
	* doc/Tcl_Main.3: 
	* doc/CrtChannel.3: 
	* doc/OpenFileChnl.3: 
	* doc/GetStdChan.3: Enhanced the manpages with cross-references to
	  the new manpage and more explanations how these functions deal
	  with the standard channels in various situations.

	* doc/StdChannels.3: New manpage describing handling of the
	  standard channels by the Tcl library [402725].

2001-09-10  Don Porter <dgp@users.sourceforge.net>

	* unix/mkLinks (Tcl_FSLink): Updated to reflect 2001-08-23
	file system changes.

	* unix/tclLoadShl.c:  Added #include of tclInt.h; access to Tcl
	internals, notably TclpUnloadFile(), is required.  Thanks to
	Bob Techentin for report and patch.  [Bug 459305]

	* generic/tclInitScript.h (initScript):
	* win/tclWinInit.c (TCL_REGISTRY_KEY, TclpSetVariables):  Removed
	vestiges of Tcl's old initialization from registry variables.
	[Bug 455645]

2001-09-10  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclInt.decls: Also added 'TclWinFlushDirtyChannels' to
	  the internal platform specific stub table.

	* win/tclWinFile.c (TclpObjStat): Now added the call to
	  'TclWinFlushDirtyChannels' to this function. I don't know where
	  my head was last thursday (2001-09-06), but the call was
	  actually added to 'TclpObjChdir', i.e. the implementation of
	  [cd]. Corrected this now. Thanks to Vince Darley for spotting
	  this.

2001-09-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclProc.c:
	* tests/proc.test: made [proc] bytecompile a no-op for procs
	defined with _args_ as single argument and an empty body.
	[FQ 451441] 
	
2001-09-09  Mo DeJong  <mdejong@users.sourceforge.net>

	* unix/Makefile.in:
	* win/Makefile.in: Use () around variable name
	instead of {}. Use TCLTEST variable directly
	instead of depending on the tcltest alias.

2001-09-09  David Gravereaux <davygrvy@pobox.com>

	* generic/tcl.h:
	* generic/tclPlatDecls.h:  Reminder from David Cuthbert <dacut@kanga.org>
	that I hadn't finished the Borland compatibility stuff.
	[Patch: 436116]

2001-09-09  Mo DeJong  <mdejong@users.sourceforge.net>

	* tests/cmdAH.test: Modify cmdAH-20.5 and cmdAH-24.8
	to display the file atime or mtime results if
	the test fails.

2001-09-08  David Gravereaux <davygrvy@pobox.com>

	* win/mkd.bat:
	* win/rmd.bat: made these text files, text files again.
	[Patch: 451333]

2001-09-08  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/mkd.bat:
	* win/rmd.bat:
	Apply binary property (cvs admin -kb) to files and convert
	to CRLF linefeed format to fix the VC++ build. [Bug #219409]

2001-09-08 Vince Darley <vincentdarley@users.sourceforge.net>

	* generic/tclInt.h: 
	* generic/tclFCmd.c:
	* doc/FileSystem.3:
	* generic/tclIOUtil.c: removed Tcl_FSCopyFile fallback
	to channel copying, since the channels will not have
	access to interpreters and the channel copying currently
	requires an interp.  Code which required cross-platform
	copies always has interpreters, so that solves the problem.
	Fixes bug in TclKit.
	
2001-09-07  David Gravereaux <davygrvy@pobox.com>

	* win/tcl.m4: Added -link50compat option so a VC6 linker makes
	a VC5 (pre sp3) compatible import library.
	[Bug: 219257]

2001-09-07  Mo DeJong  <mdejong@users.sourceforge.net>

	* win/tclWinThrd.c (TclpThreadExit): Cast status argument to
	_endthreadex to unsigned instead of DWORD to match the Win32
	function prototype.

2001-09-06  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* All the changes below serve to fix bug [219148] which reports a
	  80x performance hit for file I/O on Win* systems. On my system
	  it was closer to a 120x hit. Problem report by Uwe Traum <no
	  email address available>.

	  The fix goes like this: The obstacle is 'FlushFileBuffers',
	  executed whenever Tcl writes data to the OS, as Tcl has to wait
	  for the disk to complete I/O, and disks are slow. We remove that
	  obstacle. This opens another problem, [file size] reports back
	  wrong numbers. So for [file size] we add the call back in. As
	  optimization we keep track of the channels which were written to
	  and flush only these.

	* win/tclWinFile.c (TclpObjStat): Added a call to
	  'TclWinFlushDirtyChannels'. This ensures that [file size] and
	  related commands report the correct size of a file even if Tcl
	  has recently written to it. Unixoid OS's always report the
	  correct size even for files with pending data, but Win*
	  syssystem don't. They only report what is actually on disk.

	* win/tclWinInt.h: Added declaration of
	  'TclWinFlushDirtyChannels', making it available to other parts
	  of the tcl core.

	* win/tclWinChan.c (TclWinFlushDirtyChannels): New, internal,
	  procedure. Goes through the list of open file channels and
	  forces the OS to flush its file buffers for all which were
	  written to since the last call of this function. This is an
	  expensive operation as Tcl has to wait for the OS to complete
	  actual writes to the disk.

	  (FileInfo): Added dirty flag required by the procedure above.

	  (FileOutputProc): Removed flushing of file buffers, setting the
	  dirty flag instead. This means that the previously incurred
	  delays do not happen anymore.

	  (TclWinOpenFileChannel): Added initialization of 'dirty' flag.

2001-09-06  Jeff Hobbs  <jeffh@ActiveState.com>

	* doc/http.n: noted -binary, charset and coding state keys.
	* tests/http.test:
	* library/http/pkgIndex.tcl:
	* library/http/http.tcl (geturl): correctly get charset parameter
	and convert text according to specified encoding (if known).  RFC
	iso8859-1 is used by default.  Also recognize Content-encoding to
	see if we should do binary translation.  Added a CYA -binary
	switch for the cases that were missed. [Bug #219211 #219399]

	* tests/ioUtil.test: changed to make better use of constraints and
	remove knownBug constraints that weren't valid.

2001-09-06  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-3.2): Updated test to support
	  newer HP-UX releases that properly report euc-jp as the system
	  encoding for Japanese.  Bug report and patch verification by Bob
	  Techentin.  [Bug 453883]

	* doc/http.n:
	* library/http/*.tcl:
	* tools/tcl.wse.in:
	* tools/tclmin.wse:
	* unix/Makefile.in:
	* win/{Mm}akefile.*:  Updated http package to version 2.4,
	reflecting the new features just added.

2001-09-06 Vince Darley <vincentdarley@users.sourceforge.net>

	* generic/tclTest.c: tests of old-fs hooks no longer cause problems
	in threaded builds.  Also removed unused unload proc.
	* generic/tcl.decls:
	* generic/tclIOUtilc: added Tcl_FSMountsChanged so that a vfs
	can inform the filesystem that the filesystem epoch must be
	changed (since cached filesystems may now be incorrect).  Fixes
	problem running tclvfs extension.
	* library/tcltest/tcltest.tcl: if tests aren't in a native
	filesystem, then don't use pipes to run them. [Bug 458741]
	
2001-09-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tcl.decls (479 generic): 
	* generic/tclIO.c (Tcl_Seek,Tcl_Tell,Tcl_OutputBuffered): Added
	public function to return the size of the output buffer and
	reworked other channel functions to use this shared functionality
	and that of Tcl_InputBuffered() too. [TIP#49, Rolf Schroedter]

2001-09-05  David Gravereaux <davygrvy@pobox.com>

	* generic/tclPlatDecls.h:  Another small trim finalizing Borland
	support.

	* win/tclWinPipe.c:
	* win/tclWinPort.h:  More Borland compatibility fixes.  Changed
	EDQUOT #define from 49 to 69.  Borland had a clash as it was already
	using this number.  Upon advice from Helmut Giese, EDQUOT has been
	found in other header files #defined as 69.
	[Patch: 436116]

	* win/.cvsignore:  A few more glob patterns added.

	* win/makefile.bc (new):  Borland lives once more! rejoice..
	* generic/tclAlloc.c: Small Borland compatibility fix.
	* win/tclWinTime.c:  More Borland compatibility fixes.
	[Patch: 436116]

2001-09-05 Vince Darley <vincentdarley@users.sourceforge.net>

	* tests/winFCmd.test: made notWin2000 constraint false if not
	running on Windows at all.
	
2001-09-04  David Gravereaux <davygrvy@pobox.com>

	* win/tclWinThrd.c:  Revisited _beginthreadex() stuff.  Instead
	of assuming a c-runtime implimentation of _beginthreadex normal,
	I reversed the logic to not assume, and use when is by explicitly
	needing to add runtimes that support it such as Borland.

	* generic/tcl.h:
	* generic/tclPlatDecls.h:  Borland compatibility change so
	ClientData was properly typed as a void* and TCHAR would not be
	defined twice.

	* generic/tcl.h:  Removed a small mistake from before.  Changes to
	the EXTERN macro for proper Borland compatibility will have to see
	a TIP.  What's this with the MS compiler:

		__declspec(dllexport) int func (int a, int b);

	will have to be this with Borland:

		int __cdecl __export func (int a, int b);

	The order of the attribute needs to be after the return type.

2001-09-04  Don Porter  <dgp@users.sourceforge.net>

	* compat/strtod.c (strtod):  Fixed failure to handle expressions
	like 3eq2 and failure to set errno on overflow.  [Bug 440894]

2001-09-04  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclProc.c:
	* tests/proc.test: made [proc] check that formal args have
	simple names [Bug 458548] 

2001-09-04 Vince Darley <vincentdarley@users.sourceforge.net>

	Minor bug fixes in filesystem, plus small vfs changes as a 
	result of enabling the test filesystem to work properly.
	* tests/fileName.test: ensure new test cleans up after itself
	* doc/filename.n: 
	* generic/tclFileName.c: improved Mac path handling and document
	why [Bug: 421842] on Windows handling of UNC paths is not valid.
	Documentation and code now much clearer on what is and is not a 
	UNC path.
	* doc/FileSystem.3:
	* unix/tclUnixPipe.c:
	* generic/tclFCmd.c:
	* generic/tclIOUtil.c: fixed error message, fixed [Bug: 453512]
	about dangerous use of tmpnam, replaced with mkstemp.  
	Documented all the changes.
	* generic/tclTest.c: made test vfs fully functional as a 
	'reporting filesystem'.
	* generic/tcl.stubs:
	* generic/tcl.h:
	* generic/tclInt.h: 
	* generic/tclIOUtil.c:
	* doc/file.n:
	* various platform-specific 'TclpLoadFile': fixed comments about 
	unload behaviour, and completed objectification of loading.
	Required change to Tcl_Filesystem lookup table, so incompatible
	with 8.4a3, but not older versions of Tcl.  The change also
	allows 'link' and 'reporting' filesystems to function correctly
	when loading files.  Implementation of 'file delete -force'
	copes with case where cwd is inside the directory.  Moved
	overlooked Tcl_FSGetPathType from internal to external API.
	Made sure filesystems which are registered and then unregistered
	are only freed when all references to them are gone.
	Documented changes.
	* unix/tclUnixFCmd.c: when deleting directories recursively,
	make sure permissions are ok.  Together with the above, this
	fixes [Bug: 219139]
	* tests/winFCmd.test: differentiated test results for win2k 
	versus not.  This fixes [Bug: 219239]
	* tests/fCmd.test: added tests for 'file delete -force' where
	the cwd is inside, and when permissions are inadequate.
	
2001-09-04  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompile.c: fixed incorrect operands for INST_LIST
	[Bug: 458241] (David Cuthbert, dacut@users.sourceforge.net)

2001-09-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclExecute.c (TclExecuteByteCode): fixed missing comma
	in debug macro.

2001-09-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/ExprLongObj.3: Fixed error in documentation of argument type
	to Tcl_ExprObj [Bug: 457435]

2001-09-02  David Gravereaux <davygrvy@pobox.com>

	* win/tclWinThrd.c:  Portability fix for Cygwin who's c-runtime,
	not surprisingly, doesn't have the MSVCRT specific _beginthreadex /
	_endthreadex pair.  This might have to be revisited for proper
	Borland, lcc32, Watcom and other support as well.
	[Patch: 444255]

	* win/tclWinThrd.c:  Moved FinalizeConditionEvent() proto to within
	the main #ifdef TCL_THREADS block to avoid mingw warning about it
	being there but unused.

	* win/makefile.vc:  Added -Zl (zee el) to tclStubLib.c compile line
	to make sure the tclstub84.lib static library is built without
	requiring a specific C-runtime library at link-time for the end-use
	developer.  It has been noted on c.l.t that this trips many first
	time users trying to make extensions.
	[Patch: 403533]

2001-08-31  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclInt.h: added TclCompileListCmd header
	* generic/tclBasic.c: added TclCompileListCmd compile proc
	* generic/tclCompCmds.c (TclCompileListCmd): function to compile
	the 'list' command at parse time.
	* generic/tclExecute.c (TclExecuteByteCode): definition of
	INST_LIST bytecode.

	* doc/StringObj.3: added words of warning to use Tcl_ResetResult
	with the Tcl_Append* functions.

	* tests/compile.test: added compile-11.* interp result checks
	* generic/tclUtil.c (TclGetIntForIndex): added Tcl_ResetResult
	before Tcl_AppendStringsToObj to prevent shared object crash when
	called from bcc instruction.  The Tcl_Append* calls that append to
	the result object that are invoked by bcc insts must remember to
	call Tcl_ResetResult because the bcc doesn't do this for us.
	[Bug #456892]

2001-08-30  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclIndexObj.c: fixed some casting problems that upset
	Crays. [Bug #419528] (andreasen)

2001-08-30  Don Porter  <dgp@users.sourceforge.net>

	* generic/tcl.h: Silence warning from Sun compiler. [Bug 454374]

2001-08-30  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: allow cached fully-qualified command names
	to be usable from different namespaces within the same interpreter
	without forcing a new lookup. This speeds up scripts that pass
	command names in variables ("this" in some OO packages).
	[Patch 456668]. 

2001-08-30 Vince Darley <vincentdarley@users.sourceforge.net>

	Further fs updates.  After examining the most common Tcl
	extensions (TclX, BLT, Tk, TclPro, Mktclapp), it has been
	determined that only TclpGetCwd and the Access/Stat/Open
	insert/delete hooks of the internal fs functions are ever used.
	The remaining functions from Tcl's internal interfaces have
	therefore been removed, since Tcl now exports a more suitable
	public API (Tcl_FS...)
	
	* generic/tclInt.stubs:
	* generic/tclInt.h: updated for removed internal functions.
	Some new internal functions have been put in tclInt.h (and
	not exported in the stub table because good public equivalents
	exist).
	* generic/tclTest.c: some test functions used the internal private 
	APIs.  These tests have been retained, but modified to use 
	public APIs.  Also objectified the internal filesystem tests.
	* win/tclWinFile.c: removed TclpStat, TclpAccess and refactored
	code to use NativeAccess, NativeStat.  This should speed up
	stat, access and glob commands.
	* win/tclWinFCmd.c: removed all TclpCopy/Rename/Delete 
	File/Directory string-based procedures which aren't used any more.
	Improved efficiency of some other procedures. Ensure that filename
	conversions with a NULL interp do not crash Tcl.
	* mac/tclMacFCmd.c: wrapped long lines and cleaned up
	TclpObjNormalizePath, removed all TclpCopy/Rename/Delete 
	File/Directory string-based procedures which aren't used any more.
	* mac/tclMacFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
	etc.
	* unix/tclUnixFCmd.c: removed use of TclpAccess, removed all
	TclpCopy/Rename/Delete File/Directory string-based procedures which
	aren't used any more.
	* unix/tclUnixFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
	etc.
	* tcl(Unix|Mac|Win)Chan.c: objectified TclpOpenFileChannel.
	* various 'load' implementations all objectified.
	* generic/tclFileName.c: removed redundant code.
	* generic/tclIOUtil.c: removed TclStat, TclAccess, TclpListVolumes.
	Fix to MatchInDirectory at the root of a volume.  Also improved
	some documentation, and improved default path joining behaviour
	for virtual filesystems, especially regarding '~'.
	* tests/fileName.test: added tests to check for bugs fixed above.
	* doc/FileName.3: improved documentation
	
2001-08-30  David Gravereaux <davygrvy@pobox.com>

	* generic/tclAsync.c:
	* generic/tclEvent.c:
	* generic/tclInt.h: Improper cleanup of asyncMutex in tclAsync.c
	repaired.  TclFinalizeSynchronization() was trying to remove a
	registered mutex that was dumped earlier when the TSD it was stored
	in was cleared. This was only surfacing on *nix.  Windows was being
	masked by mutexes not actually being returned to the system!  That
	was repaired in a previous patch.  Needed to add a private
	TclFinalizeAsync() to tclAsync.c and called from Tcl_FinalizeThread().
	Pheww..  Is this done yet?
	[Bug: 414419] requested by Rob Ratcliff <rrr6399@futuretek.com>

2001-08-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCompCmds.c (TclPushVarName): noted 'static' defn.
	[Bug #453872]

2001-08-26  Don Porter <dgp@users.sourceforge.net>

	* library/auto.tcl (tcl_findLibrary):
	* tests/unixInit.test (unixInit-2.{1,9}):
	* unix/tclUnixInit.c (TclpInitLibraryPath):
	* win/tclWinInit.c (TclpInitLibraryPath):  Corrected 
	inconsistency between  the search path for script libraries and
	the directory name $DISTNAME into which distributions built
	by 'make test' unpack.  [Bug 455642]

2001-08-24  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/stringComp.test: added string-1.3
	* generic/tclCompCmds.c (TclCompileStringCmd): changed to return
	TCL_OUT_LINE_COMPILE instead of TCL_ERROR when compiling and an
	unknown string method is called.  This is necessary as the string
	command may be never called, or not until 'string' is redefined.

2001-08-24 Vince Darley <vincentdarley@users.sourceforge.net>

	* doc/glob.n: documented windows-style path issue with glob.
	[Bug: 219392]
	* doc/filename.n: documented windows path/file length limitation.
	[Bug: 454597]

2001-08-24  Don Porter <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-2.9): Corrected expected result
	to match Tcl's quirky construction of its init library path.

2001-08-23  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* win/tclWinPipe.c (BuildCommandLine): Fixed tcl Bug
	  [432499]. Part of the code used the non-absolute path to the
	  executable to determine quoting. This failed if the absolute
	  path contained spaces, but the application name itself not. This
	  bug caused no trouble on Win NT 5, but does for other variants
	  in the Win* family. Report and fix due to Ken Poole
	  <kenpoole@users.sourceforge.net>.

2001-08-23  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/configure:
	* unix/tcl.m4: added QNX-6 build support. [Bug #219410] (loverso)

	* unix/tclUnixFCmd.c:
	* generic/tclIOUtil.c:
	* generic/tclFileName.c: corrected minor compiler warnings.

2001-08-23 Vince Darley <vincentdarley@users.sourceforge.net>

	Variety of small filesystem and vfs issues fixed or improved.
	The new fs code allows many new opportunities for efficiency
	improvements through the objectified API. The main changes
	integrated here are such efficiency improvements.  Some
	limitations of the original implementation have also now been
	lifted.  Meanwhile a variety of fs bugs (some old, some new)
	have also been fixed.
	
	* generic/tclFileName.c: Made Tcl_FSSplitPath more efficient, 
	and removed some static string-based procedures which are no 
	longer used.  Much more objectification.  Tcl_FSJoinPath
	is now very efficient and more aware of virtual filesystems.
	Clarified where the Mac-specific code attempts to interpret
	Unix-style paths.  Modified TclDoGlob to use lstat not
	access to fix [Bug: 434876, L. Virden]
	* tcl(Win|Unix|Mac)FCmd.c:
	* tcl(Win|Unix|Mac)File.c: replaced TclpListVolumes with
	TclpObjListVolumes with different signature, updated code due
	to more efficient signature of Tcl_FSGetTranslatedPath.  Used
	cached native paths where possible to improve efficiency --
	this was completed on MacOS, but on Unix and Win the traversal
	functions make the task much more complex, so there are still
	some improvements possible there.  Removed unused 
	TclpNormalizePath which had been left in tclWinFCmd.c.
	Objectified all 'file attributes' functions.  Fixed the new
	[Bug:451571, Bruce Stephens] which is most obvious on Unix, 
	but could occur on MacOS or Windows.  This bug actually existed
	in Tcl 8.3.x but was only made obvious by the recent filesystem
	overhaul when the code was exercised more heavily.  
	* tests/fileName.test: Three new tests to exercise the above bug,
	and make sure it is fixed correctly.
	* unix/tclUnixFile.c: avoid panic in glob when a link
	doesn't point anywhere.  It would probably be good to define
	exactly what Tcl should do in circumstances like these, and
	make sure mac/win/unix all behave accordingly. [Bug: 417111, 
	Hemang Lavana]. Also fixed misleading/obsolete comment in the code.
	* generic/tcl.stubs: changed signature of Tcl_FSGetTranslatedPath
	and added Tcl_FSGetTranslatedStringPath.
	These changes allow further optimisations in the FS code.
	* generic/tcl.h: changed signature of Tcl_FSListVolumes so that 
	it doesn't require a Tcl interpreter plus result.  Renamed 
	Tcl_FSReadLink to Tcl_FSLink with additional argument so
	we can support making links in the future. [Patch: 450340]
	* generic/tclInt.h:
	added declaration for TclpObjListVolumes.  Objectified 
	internal call signatures for 'file attributes' functions, and
	added an internal objectified get path type function.
	* generic/tclIOUtil.c: added the moved function TclpListVolumes 
	which calls platform specific code (needed for backwards 
	compatibility), and improved efficiency of parts of the FS
	(particularly file normalization).  Much less copying and
	memory allocation is required now.  added new GetPathType 
	so that changes in 'file volumes' can actually affect files'
	types, and objectified more code.  Made current code work
	with test suite artificially changing current platform.
	Added 'static' keywords where required.
	* generic/tclIO.c:
	* generic/tclTest.c: Added 'static' keywords, fixing 
	[Bug: 453872, Bob Techentin]
	* generic/tclCmdAH.c: file command implementation updated for 
	API changes, removed unnecessary special-case SplitPath static
	function, since it no longer helps prevent code duplication.
	Moved setting of interpreter result to each individual location
	that actually required it, to avoid very large code separation
	between reading and setting the result.
	* doc/FileSystem.3: updated documentation for the new or 
	changed APIs, and clarified some issues.
	* doc/SplitPath.3: added pointer to newer APIs in FileSystem.3
	* doc/filename.n: clarified current implementation of tilde
	support on Mac/Win.  [Bug:453514, Sergey Kuzmin]
	* doc/glob.n: improved documentation for '-directory' and '-path' 
	options.
	
	There are now many private, obsolete, platform-specific 'Tclp' 
	string-based filesystem APIs which could be removed.  We should
	check whether any of these are used by extensions and, at least
	in Tcl 9, remove them.
	
	The above changes signify a ***POTENTIAL INCOMPATIBILITY*** 
	with 8.4a3, since signatures of two functions in the new API 
	have changed, but not with older versions of Tcl.

2001-08-23  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclBinary.c (FormatNumber): Extract a long from the
	object and not an int, to stop [binary format] from being unable
	to format some input numbers on architectures where sizeof(int) is
	less than sizeof(long) (particularly Alpha.)  [tiprender Bug #441861]

	* tests/format.test: Converted conditional execution of tests into
	a test constraint.

2001-08-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/Makefile.in:
	* win/makefile.vc: updated install target for dde1.2
	* doc/dde.n: fixed dde man page (which was totally incorrect).
	* tests/winDde.test:
	* win/tclWinDde.c (Tcl_DdeObjCmd): added -binary option to dde
	request command to allow for returning binary data. [Bug #227482]
	Updated dde to 1.2

	* tests/tcltest.test: added unixExecs constraint to files that
	used 'grep' in the test. [Bug #453143]

	* library/tcltest/tcltest.tcl: fixed stdio constraint test.
	[Patch #454050] (stanton)
	Simplified unixExecs constraint test. 
	
2001-08-22  Don Porter <dgp@users.sourceforge.net>

	* tests/ioUtil.test (ioUtil-3.*): Corrected errors in tests
	revealed by fix of overagressive compiler.  [Bug 451200]

2001-08-21  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclCompCmds.c:
	* tests/compile.test: Fixed overagressive compilation of [catch]:
	it was catching errors at substitution time. [Bug #219184]
	
2001-08-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/tcltest.test (tcltest-12.2): fixed test that would break
	when env vars weren't Tcl list friendly [Patch #454046] (stanton)

2001-08-20  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/http/http.tcl (geturl): added port number to Host:
	header to comply with HTTP/1.1 spec (RFC 2068).  [Bug #452217]

2001-08-16  David Gravereaux <davygrvy@pobox.com>

	* tools/tcl.wse.in:
	* tools/tcl.hpj.in:
	* win/tcl.hpj.in:  Removed -kb storage in CVS to ensure these text
	files are checked-out in the translation mode CVS is in.  Setting
	these as binary as part of an effort to make sure they are always
	in CRLF, no matter what the CVS translation, is bypassing how CVS
	works and is confusing.

	* tools/genStubs.tcl:  Removed LF-only output.  Having to reconvert
	back to CRLF before committing to CVS was giving me a headache.
	[Bug: 451333]

	* win/makefile.vc: replaced $(WINDIR) with $(include32) for the
	.rc.res inference rule.  winver.h wasn't getting included.
	[Bug: 445630]

2001-08-14  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclBasic.c: make the intial maxNestingDepth of an
	interpreter be MAX_NESTING_DEPTH instead of a hardwired value
	[Bug: 232564]

2001-08-13  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/trace.test: Corrected test numbers [Bug: 449794] 

2001-08-12  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in:
	* unix/tcl.m4: Use GCC variable set by AC_PROG_CC instead
	of defining our own using_gcc variable.

2001-08-11  Vince Darley <vincentdarley@users.sourceforge.net>

	Variety of small issues introduced by the vfs code fixed:
	* generic/tclIOUtil.c: uninitialised read.
	* generic/tclFCmd.c: possible memory leak in file delete 
	with error condition.

2001-08-10  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclVar.c: 
	* tests/trace.test: Insure that [array] traces work correctly for
	undefined variables [Bug: 449094] 

2001-08-09  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Delete the unused getcwd.o
	target. This fixes bug #440942.

2001-08-08  Don Porter <dgp@users.sourceforge.net>

	* library/dde/pkgIndex.tcl:
	* library/http/http.tcl:
	* library/http/pkgIndex.tcl:
	* library/msgcat/msgcat.tcl:
	* library/msgcat/pkgIndex.tcl:
	* library/opt/optparse.tcl:
	* library/opt/pkgIndex.tcl:
	* library/reg/pkgIndex.tcl:
	* library/tcltest/tcltest.tcl:
	* library/tcltest/pkgIndex.tcl: Added checks for package dependencies.
	Bumped patchlevels of changed packages:  http 2.3.2, msgcat 1.2.2,
	opt 0.4.3, tcltest 2.0.1.  [Patch 448931]

	* README:
	* generic/tcl.h:
	* tools/tcl.wse.in:
	* unix/configure:
	* unix/configure.in:
	* unix/tcl.spec:
	* win/README.binary:
	* win/configure:
	* win/configure.in: Bumped up patchlevel to 8.4a4 to distinguish
	CVS snapshots from the 8.4a3 release.  This does not necessarily
	mean there will be an 8.4a4 release.  [Bug 448938].

2001-08-06  Jeff Hobbs  <jeffh@ActiveState.com>

	8.4a3 RELEASE

	* changes:
	* README:
	* mac/README: 
	* unix/README:
	* win/README.binary: updated for 8.4a3 release

	* generic/tclFileName.c (Tcl_FSSplitPath): update to Tcl style
	guide.

	* generic/tclFCmd.c (FileCopyRename): fixed mem leak in
	introduction of vfs code where a new Tcl_Obj wasn't freed.

	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd):
	reordered the retrieval of arguments to avoid shimmering bug when
	the pattern and string referenced the same object.

	* unix/configure: regenerated
	* unix/tcl.m4: added GNU (HURD) configuration target. (brinkmann)
	[Patch: #442974]

	* win/README: made note of URL for Windows compilation notes

	* win/tclWinThrd.c (TclpFinalizeMutex, TclpFinalizeCondition):
	added DeleteCriticalSection calls for cleanup [Patch: #419683]

	* unix/tclUnixPipe.c (TclpCreateTempFile): fixed use of tmpnam,
	which is dangerous. [Patch: #442636] (lim)
	The use of tmpnam in TclpTempFileName must still be changed.

	* tests/http.test (http-4.14): fixed variable error return.
	[Bug: 424252]

2001-08-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/configure: regenerated
	* win/tcl.m4: fixed DLLSUFFIX definition to always be ${DBGX}.dll.
	This is necessary for TEA compliant builds that build shared
	against a static-built Tcl.
	* win/Makefile.in ($(TCLSH)): added $(TCL_STUB_LIB_FILE) to build
	target, otherwise it wouldn't get generated in a static build.

2001-08-06  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclIOCmd.c (Tcl_GetsObjCmd): Applied patch from SF item
	  [442665] to fix the bug reported by it. The function can corrupt
	  a freed object if it is called with objc == 3. This is because
	  it retrieves resultPtr and does not increment its reference
	  count, but then calls Tcl_ObjSetVar2, which causes the retrieved
	  resultPtr object to be released.
	
2001-08-06  Don Porter <dgp@users.sourceforge.net>

	* doc/tclsh.1:  Added note that the tclsh program is frequently
	installed with the Tcl version numer as part of the name.
	[Patch 402725]

	* generic/tclPkg.c:
	* tests/pkg.test:  [package forget] now forgets all of the
	package arguments it receives, not stopping when a package is
	not found.  [Bug 415273]

2001-08-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclIOUtil.c (Tcl_FSMatchInDirectory): corrected
	uninitialized value.

2001-08-02  Mo DeJong  <mdejong@redhat.com>

	* generic/tclPlatDecls.h:
	* win/tclWinPort.h:
	Revert <tchar.h> related changes made to improve
	Cygwin support on 2001-07-18. This change ended
	up breaking the VC++ build because of conflicts
	between Windows APIs and internal Tk APIs.

2001-08-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/tclUnixFCmd.c: minor casts to eliminate warnings. (lim)
	[Patch: #440218]

	* tests/parseOld.test: changed some tests that required
	testwordend to exist to skip in a proper tcltest manner.
	[Bug: #442663]

	* library/http/http.tcl (http::mapReply): the regsub'ing of \n and
	\t to escape them was unnecessary.

2001-07-31  Vince Darley <vincentdarley@users.sourceforge.net>

	Changes from TIP#17 "Redo Tcl's filesystem"
	The following files were impacted:
	* doc/Access.3: 
	* doc/FileSystem.3: 
	* doc/OpenFileChnl.3: 
	* doc/file.n: 
	* doc/glob.n: 
	* generic/tcl.decls: 
	* generic/tcl.h: 
	* generic/tclCmdAH.c: 
	* generic/tclCmdIL.c: 
	* generic/tclCmdMZ.c: 
	* generic/tclDate.c: 
	* generic/tclDecls.h: 
	* generic/tclEncoding.c: 
	* generic/tclFCmd.c: 
	* generic/tclFileName.c: 
	* generic/tclGetDate.y: 
	* generic/tclIO.c: 
	* generic/tclIOCmd.c: 
	* generic/tclIOUtil.c: 
	* generic/tclInt.decls: 
	* generic/tclInt.h: 
	* generic/tclIntDecls.h: 
	* generic/tclLoad.c: 
	* generic/tclStubInit.c: 
	* generic/tclTest.c: 
	* generic/tclUtil.c: 
	* library/init.tcl: 
	* mac/tclMacFCmd.c: 
	* mac/tclMacFile.c: 
	* mac/tclMacInit.c: 
	* mac/tclMacPort.h: 
	* mac/tclMacResource.c: 
	* mac/tclMacTime.c: 
	* tests/cmdAH.test: 
	* tests/event.test: 
	* tests/fCmd.test: 
	* tests/fileName.test: 
	* tests/io.test: 
	* tests/ioCmd.test: 
	* tests/proc-old.test: 
	* tests/registry.test: 
	* tests/unixFCmd.test: 
	* tests/winDde.test: 
	* tests/winFCmd.test: 
	* unix/mkLinks: 
	* unix/tclUnixFCmd.c: 
	* unix/tclUnixFile.c: 
	* unix/tclUnixInit.c: 
	* unix/tclUnixPipe.c: 
	* win/tclWinFCmd.c: 
	* win/tclWinFile.c: 
	* win/tclWinInit.c: 
	* win/tclWinPipe.c

2001-07-24  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinThrd.c (Tcl_CreateThread): Close Windows
	HANDLE returned by _beginthreadex. The MS documentation
	states that this handle is not closed by a later call to
	_endthreadex.

2001-07-21  Don Porter  <dgp@users.sourceforge.net>

	* doc/pkgMkindex.n:
	* library/package.tcl:  Corrected documentation and usage
	message of [pkg_mkIndex].

2001-07-18  Mo DeJong  <mdejong@redhat.com>

	* generic/tclPlatDecls.h: Define TCHAR by including
	windows.h instead of tchar.h since Cygwin does not
	support the tchar.h header. Include CHECK_UNICODE_CALLS
	logic from tclWinPort.h.
	* win/tclWinPort.h: Remove CHECK_UNICODE_CALLS logic.
	Remove include of windows.h since this now done it
	tclPlatDecls.h.
	* win/tclWinReg.c: Remove duplicate include of windows.h.

2001-07-18  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclIO.c: Aftermath to [SF #427196]. Squash empty buffers
	  if they are smaller than the requested buffersize, to prevent
	  reusage of old buffers and to honor changes in the requested
	  buffersize made by the user.

2001-07-17  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinFile.c (TclpReadlink): Add Cygwin specific definition
	for the TclpReadlink function. This method implements reading of
	symbolic links when build with Cygwin.

2001-07-17  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinPort.h: Add Cygwin specific defines for environ
	and timezone variables.

2001-07-17  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* generic/tclIO.c (GetInput): Fixed [SF #427196]. Memory was
	  overwritten because a buffer was used after a change of the
	  requested buffersize together with that requested buffersize and
	  not its actual size, which was smaller. Note that the continous
	  reuse of the smaller buffer negatively impacts performance. The
	  system never allocates a buffer with the newly requested bigger
	  buffersize.

2001-07-16  Mo DeJong  <mdejong@redhat.com>

	* generic/tcl.h: Define __WIN32__ when
	__CYGWIN__ or __MINGW32__ is defined.
	* generic/tclAlloc.c: Define caddr_t when
	compiling with VC++ or mingw. This type is
	already defined when compiling with Cygwin.

2001-07-16  Mo DeJong  <mdejong@redhat.com>

	* win/tclWinConsole.c:
	* win/tclWinPipe.c:
	* win/tclWinPort.h:
	* win/tclWinSerial.c:
	* win/tclWinThrd.c:
	Remove unnecessary #includes of dos.h, direct.h,
	and tchar.h. This will help the Cygwin porting
	effort since these headers do not exist under Cygwin.

2001-07-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* win/tclWinPipe.c (PipeClose2Proc): constrained the mutex lock to
	just the TerminateThread call and waiting for termination. (jsmith)

	* generic/tclCmdMZ.c: Removed extra copy of the SCAN_* macros
	#defined in generic/tclScan.c. (porter) [Bug 441230]

2001-07-12  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-2.8): Added extra constraint,
	notInstalledInTmp, to stop this test from damaging installations
	in /tmp; not much fun to have to reinstall the Tcl library every
	time you run the test suite!

	* tests/subst.test (subst-10.*): Updated tests to check new
	behaviour for 'break' in command substitutions.
	(subst-1.2,subst-7.1): Error messages changed.
	* doc/SubstObj.3: New file, to document Tcl_SubstObj.
	* doc/subst.n: Improved and updated documentation for 'subst' to
	help support the changed behaviour.
	* generic/tcl.decls (generic-437): Declaration for Tcl_SubstObj
	* generic/tcl.h (TCL_SUBST_*): Added flags for Tcl_SubstObj.
	* generic/tclCmdMZ.c (Tcl_SubstObj,Tcl_SubstObjCmd): Divided into
	two parts to allow people to access the innards of 'subst' and
	changed the behaviour when command substitutions do a 'break' to
	be different from 'continue'.  Also now works with objects, which
	allows for some nifty optimisations with variable substitutions
	and a slight improvement with command substitutions.  [TIP#36]

2001-07-10  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Add AR variable for use in STLIB_LD.
	* unix/configure: Regen.
	* unix/configure.in: Use STLIB_LD when defining MAKE_LIB
	and MAKE_STUB_LIB. Subst RANLIB and AR.
	* unix/tcl.m4 (SC_CONFIG_CFLAGS): Add doc comment about
	STLIB_LD command. Check ${AR} env var when setting
	STLIB_LD and delay evaluation until make time.
	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Delay evaluation of
	${AR} in STLIB_LD and add flags to better match the
	Unix implementation. Don't bother defining AR when
	using VC++ since it is not used.

2001-07-06  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Pass -e _WinMain@16 in
	addition to the -mwindows flag to work around a problem
	with ld when it incorrectly use main() as the executable
	entry point when both WinMain() and main() are available.

2001-07-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/cmdAH.test: Added leading zero to file modes to work
	around fault in HPUX strtol() which ignores the base parameter
	[Bug #438808]

2001-07-05  Mo DeJong  <mdejong@redhat.com>

	* win/Makefile.in: Subst DEPARG directly instead
	of relying on a variable. This will make Cygwin
	builds faster since an extra exec will be avoided.
	* win/configure: Regen.
	* win/configure.in: Subst DEPARG.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Move AC_MSG_CHECKING
	after the AC_CHECK_PROG so that status messages do
	not get mixed together. Set DEPARG based on the
	results of the cygpath check so that we avoid using
	an extra exec when it is not needed. Use ac_cv_cygwin
	status flag instead of looking at the output of
	gcc -v, which works in the case where -mno-cygwin is
	set in the CFLAGS.

2001-07-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* README:
	* mac/README:
	* unix/README:
	* win/README:
	* win/README.binary: updated READMEs with purls

2001-07-03  Mo DeJong  <mdejong@redhat.com>

	* win/Makefile.in: Remove PATHTYPE variable.
	* win/configure: Regen.
	* win/configure.in: Don't subst PATHTYPE.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Remove PATHTYPE
	variable. Set CYGPATH to "cygpath -w" if the
	cygpath executable is found on the path. This
	approach works for native Cygwin builds and
	cross compiles.

2001-07-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/var.test:
	* generic/tclVar.c (Tcl_VariableObjCmd): added patch to check for
	number of args. [Patch #426038]

	* generic/tclVar.c (Tcl_GetVar2Ex): added ability to recognize
	TCL_TRACE_READS flags to cause creation of part1 in TclLookupVar
	to make sure newly created array will get read traces triggered
	appropriately.  This is called by Tcl_ObjGetVar2, Tcl_GetVar, and
	Tcl_GetVar2.
	(TclSetIndexedScalar, TclSetElementOfIndexedArray): added read
	trace triggering for lappend case.
	(Tcl_LappendObjCmd): pass TCL_TRACE_READS to Tcl_ObjGetVar2 to
	trigger possible read traces for new arrays.

	* generic/tclExecute.c (TclExecuteByteCode): added TCL_TRACE_READS
	flag to INST_LAPPEND(_ARRAY)_STK case to trigger read traces for
	newly created arrays.  Removed unnecessary #ifdef for
	TCL_COMPILE_DEBUG in INST_LOAD_SCALAR1 case.

	* tests/append.test:
	* tests/appendComp.test: added tests for read trace triggering for
	append and lappend.

2001-07-03  Mo DeJong  <mdejong@redhat.com>

	* tests/clock.test (clock-2.5): Adjust test so that it passes
	when the time slice is 60 msecs, now passes under Windows 98.

2001-07-03  Mo DeJong  <mdejong@redhat.com>

	* win/tcl.m4 (SC_CONFIG_CFLAGS): Don't pass the v flag
	to ${AR} when using gcc, verbose output is not needed.

2001-07-03  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-2.8):  Changed test back to using
	installation layout, adding comments explaining why the test writes
	to the directories it does, and checks to avoid destroying other
	files in /tmp.

2001-07-03  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-1.2): Fixed faults reported in
	Bug#438070 - well, at least enough to work on Solaris - and added
	comments that should make what is going on in the test clearer.

2001-07-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/util.test: added util-4.6
	* generic/tclUtil.c (Tcl_ConcatObj): Corrected walking backwards
	over utf-8 chars. [Bug #227512]

2001-07-02  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test (unixInit-2.8):  Corrected test for all
	absolute pathnames in library path when executable is installed
	near root directory to use correct development directory layout.
	[Bug 438014]

	* tests/unixInit.test (unixInit-2.9):  
	* unix/tclUnixInit.c (TclpInitLibraryPath):
	* win/tclWinInit.c (TclpInitLibraryPath):  Corrected buggy
	construction of search path entries relative to executable.
	Added test for bad construction.  [Bug 438014]

2001-06-28  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclNamesp.c: Correction to faulty patch from [Bug: 231259] 

2001-06-28  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-1.2): Modified so as not to
	require a local echo service, which fails on many systems which
	have that turned off for security reasons...

2001-06-27  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclInt.h:
	* generic/tclObj.c:
	* unix/Makefile.in: added a -DPURIFY mode that makes Tcl_Obj's
	allocated and free singularly (instead of in alloc in blocks and
	never free) to allow checkers like Purify to operate better.

	* library/encoding/koi8-u.enc: added koi8-u (Ukranian variant)
	encoding.

	* tests/subst.test:
	* generic/tclUtf.c (Tcl_UtfBackslash): Corrected backslash
	handling of multibyte utf-8 chars. [Bug #217987]

	* generic/tclCmdIL.c (InfoProcsCmd): fixed potential mem leak in
	info procs that created objects without using them.

	* generic/tclCompCmds.c (TclCompileStringCmd): fixed mem leak when
	string command failed to parse the subcommand.

	* doc/interp.n:
	* doc/unknown.n: updated notes about what is in a safe interp.
	[Bug #218605]

2001-06-27  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/event.test (event-11.5): Removed hard-coded port number
	which could fail on some systems.  [Bug #436727]

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in:
	* win/Makefile.in: Add `make shell` target. This target
	will set the proper env vars before invoking tclsh
	from the build directory.

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* win/Makefile.in: Use : to separate VPATH entries. This
	works for both Cygwin builds and cross builds, the VPSEP
	variable is simply unneeded complexity.
	* win/configure: Regen.
	* win/configure.in: Don't subst VPSEP.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Remove VPSEP variable.

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in: Fix last checkin by removing
	export since that only works in bash.
	* win/configure: Regen.
	* win/configure.in: Ditto.

2001-06-26  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in: Set CFLAGS to "" if the user
	did not set CFLAGS in the env. This keeps AC_PROG_CC
	from adding "-g -O2" to the CFLAGS by default.
	* win/configure: Regen.
	* win/configure.in: Ditto.

2001-06-25  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/configure.in: Use RC_DEFINE flag from tcl.m4.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Set RC_DEFINE
	flag based on the compiler in use.
	
2001-06-25  Mo DeJong  <mdejong@redhat.com>

	* win/tcl.m4 (SC_CONFIG_CFLAGS): Link to the
	imm32 library when building with mingw gcc.

2001-06-25  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/tcl.m4 (SC_CONFIG_CFLAGS): When building with
	gcc, don't attempt to link with LD or support dllwrap.
	Simply require a recent version of Cygwin gcc or Mingw
	gcc that supports -shared. When linking, use gcc instead
	of ld since gcc automatically includes libs like -lmsvcrt.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/configure.in: Add resource compiler fix from
	8.3.3 to fix compiling with mingw.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* win/configure: Regen.
	* win/tcl.m4: Fix silly typo in last checkin.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
	Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@. Add LDFLAGS_DEBUG
	and LDFLAGS_OPTIMIZE to match the way CFLAGS_DEFAULT works.
	This will support user set CFLAGS or LDFLAGS at configure time.
	* unix/configure: Regen.
	* unix/configure.in: Don't set CFLAGS to CFLAGS_DEFAULT, instead
	subst CFLAGS_DEFAULT into the Makefile. Add AC_SUBST for CFLAGS_DEFAULT,
	LDFLAGS_DEFAULT, LDFLAGS_DEBUG, and LDFLAGS_OPTIMIZE.
	* unix/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
	it uses a Makefile variable just like CFLAGS_DEFAULT.
	* win/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
	Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@.
	This will support user set CFLAGS or LDFLAGS at configure time.
	* win/configure: Regen.
	* win/configure.in: Don't set CFLAGS or LDFLAGS, instead subst
	CFLAGS_DEFAULT and LDFLAGS_DEFAULT into the Makefile.
	* win/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
	it uses a Makefile variable just like CFLAGS_DEFAULT.

2001-06-22  Mo DeJong  <mdejong@redhat.com>

	* win/configure:
	* win/tcl.m4 (SC_CONFIG_CFLAGS): Don't set LDFLAGS_DEBUG
	to -g or LDFLAGS_OPTIMIZE to -O when compiling with gcc.
	These flags are not needed and can cause problems with
	the Cygwin version of ld.

2001-06-18  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/unixInit.test (unixInit-1.2,unixInit-2.8): Added test for
	code described below, and fixed a couple of errors that caused
	problems during testing; the code to determine the installedTcl
	constraint was wrong, and test unixInit-2.8 assumed that /tmp/lib
	was free for use and could be deleted, which clashed nastily with
	my installation and made other tests fail unnecessarily!

	* unix/tclUnixChan.c (TtyInit,TclpOpenFileChannel,
	Tcl_MakeFileChannel,TclpGetDefaultStdChannel): Alterations so that
	the standard channels - stdin, stdout and stderr - have the
	correct type and fconfigure options.  This required making the
	initialisation of serial lines a little more sophisticated to
	make the console behave correctly in interactive mode... [Bug
	#219137 and duplicates]

2001-06-16  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclInt.decls:
	* generic/tclInt.h: 
	* generic/tclPanic.c (Tcl_PanicVA):
	* mac/tclMacAppInit.c (main):
	* mac/tclMacPanic.c (TclpPanic):
	* unix/tclUnixPort.h:
	* win/tclWinPort.h: Replaced TclMacSetPanic with TclpPanic
	for setting a platform-specific panic handler.  TclpPanic
	is NULL on Unix and Windows.  Fixes broken wish on Mac due
	to earlier patches.  [Patch 415648]
	
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: `make gentubs` after above changes.

2001-06-13  Don Porter  <dgp@users.sourceforge.net>

	* mac/tclMacAppInit.c (main, Macintosh_Init):
	* mac/tclMacBOAAppInit.c (main):
	* mac/tclMacPanic.c: Applied patches from Dan Steffen correcting
	problems on the Macintosh in the 2001-06-08 changes.

2001-06-12  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/regexp.test (regexp-18.12): 
	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): Fixed so that submatches
	that do not match always have index pair {-1 -1} [Bug #219232]

2001-06-08  Don Porter  <dgp@users.sourceforge.net>

	* generic/tcl.h:
	* generic/tcl.decls:
	* generic/tclPanic.c: Added CONST to Tcl_*Panic* public interfaces.
	[Patch 415648, TIP 27]

	* generic/tclInt.decls:
	* mac/tclMacAppInit.c (main):
	* mac/tclMacBOAAppInit.c (main):
	* mac/tclMacPanic.c: Modified special Mac implementations of
	Tcl_*Panic* to be exact copies of the generic implementations.
	Added TclMacSetPanic.  The generic implementations should be
	used directly, rather than copies, but that requires further
	changes by someone familiar with the Mac build systems.
	[Patch 415648]

	* generic/tclDecls.h:
	* generic/tclIntPlatDecls.h:
	* generic/tclStubInit.c: `make gentubs` after above changes.

	* doc/Panic.3:
	* unix/mkLinks:  New file documenting Tcl_*Panic* public interfaces,
	followed by `make mklinks`.  [Patch 415648, Bug 219170, Bug 414936]

2001-06-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclUtil.c (Tcl_DStringAppendElement): patch to save an
	extra strlen call.  [Bug #428572]

2001-05-30  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclExecute.c (TclExecuteByteCode): Added two casts to
	INST_STR_CMP implementation to get rid of a couple warnings from
	the SUNWspro C compiler.

	* generic/tclBasic.c (Tcl_GetMathFuncInfo,Tcl_ListMathFuncs): 
	* generic/tclCmdIL.c (Tcl_InfoObjCmd,InfoFunctionsCmd): 
	* generic/tcl.decls (generic table, positions 435+436): 
	* tests/info.test: 
	* doc/CrtMathFnc.3: 
	* doc/info.n: Changes due to TIP #15 "Functions to List and Detail
	Math Functions"

2001-05-28  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/init.tcl (unknown): removed errant " in error message

2001-05-27  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/regc_locale.c: updated character class range data for
	Unicode v3.1.0 compliance.
	* generic/tclUniData.c: regenerated from Unicode v3.1.0 data file
	(new as of 2001-05-16).  This brings Tcl to current unicode
	compliance.

	* tests/utf.test: added tests to check unicode 3 compliance

	* unix/Makefile.in (tclUtf.o): added tclUniData.c dependency.

	* tools/uniClass.tcl: added comments to output format and the
	script for clarification.

	* tools/uniParse.tcl: corrected filename output and GetDelta macro
	to use 'info' as param (was 'infO')

2001-05-26  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclVar.c (tclArraySearchType,SetArraySearchObj,
	ParseSearchId): Added code to speed up array searching by reducing
	the amount of parsing needed for searchIds.

	* generic/tclObj.c (TclInitObjSubsystem): 
	* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): 
	* generic/tclNamesp.c (TclInitNamespaceSubsystem): 
	* generic/tclInt.h: Moved some Tcl_ObjType initialisation to
	TclInitObjSubsystem to be with the bulk of the rest.
	[Patch 424851] Committed by Miguel Sofer <mig@utdt.edu>

2001-05-23  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/io.test: changed io-52.[9-11] to not be platform sensitive
	with EOL translation.

	* library/encoding/cp1250.enc:
	* library/encoding/cp1251.enc:
	* library/encoding/cp1252.enc:
	* library/encoding/cp1253.enc:
	* library/encoding/cp1254.enc:
	* library/encoding/cp1255.enc:
	* library/encoding/cp1256.enc:
	* library/encoding/cp1257.enc:
	* library/encoding/cp1258.enc:
	* library/encoding/cp874.enc:
	* library/encoding/iso8859-6.enc:
	* library/encoding/iso8859-7.enc:
	* library/encoding/iso8859-8.enc:
	* library/encoding/iso8859-10.enc (new):
	* library/encoding/iso8859-13.enc (new):
	* library/encoding/iso8859-14.enc (new): updated encoding tables
	based on http://www.unicode.org/Public/MAPPINGS/. (kuhn)

2001-05-23  Mo DeJong  <mdejong@redhat.com>

	* unix/tcl.m4 (SC_PATH_TCLCONFIG): Fix comments,
	and typo in cached variable name.

2001-05-23  Mo DeJong  <mdejong@redhat.com>

	* unix/tcl.m4 (SC_LOAD_TKCONFIG):
	Remove use of undefined TCLCONFIG variable and
	call AC_MSG_RESULT to print the checking result.
	* win/tcl.m4: Ditto.

2001-05-22  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclObj.c (TclAllocateFreeObjects): simplified
	objSizePlusPadding to use sizeof(Tcl_Obj) (max)
	Corrected use of tclObjsAlloced/Freed/Shared in TCL_MEM_DEBUG
	compile.

2001-05-22  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: removed Tcl_DuplicateObj in INST_DUP 

2001-05-21  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/tcltest.test (tcltest-19.1): fixed failing test that was
	getting affected by Windows env handling of empty valued elements.

	* unix/tcl.m4: added more common install directories in which to
	search for *Config.sh [Bug #419812]

	* tests/cmdMZ.test (cmdMZ-1.4): added notLinux constraint to test
	to prevent failure message on Linux due to OS caching bug.

	* tests/httpd (httpdRespond): added response to timeout value in
	query string.

	* tests/http.test: removed unused notLinux constraint setting

	* generic/tclRegexp.c (Tcl_RegExpExecObj): added use of
	Tcl_GetUnicodeFromObj.

2001-05-19  Andreas Kupries <andreas_kupries@users.sourceforge.net>

	* Note that "tclbench" (see project "tcllib") was extended with
	  performance benchmarks for [fcopy] too.

	* doc/fcopy.n: Updated to reflect the extended behaviour of 'fcopy'.

	* tests/io.test: Added tests 'io-52.9', 'io-52.10' and 'io-52.11'
	  to test the handling of encodings by 'fcopy' / 'TclCopychannel'
	  [Bug #209210].

	* generic/tclIO.c: Split of both 'Tcl_ReadChars' and
	  'Tcl_WriteChars' into a public error checking and an internal
	  working part. The public functions now use the new internal
	  ones. The new functions are 'DoReadChars' and 'DoWriteChars'.
	  Extended 'CopyData' to use the new functions 'DoXChars' when
	  required by the encodings on the input and output channels
	  [Bug #209210].

2001-05-16  Jeff Hobbs  <jeffh@ActiveState.com>

	* library/history.tcl (tcl::HistAdd): prevent empty calls from
	being added to the history (arndt)

	* tests/error.test: updated error-1.3 message to account for
	string index being compiled at toplevel.
	* tests/appendComp.test:
	* tests/stringComp.test: new files for extended bytecode testing

	* generic/tclBasic.c: added new CompileProc invocations to basic
	command initialization.
	* generic/tclCompCmds.c: added new compile commands for append,
	lappend, lindex and llength.  Refactored set and incr compile
	commands to use new TclPushVarName function for handling the
	varname component during compilation (also used by append and
	lappend).  Changed string compile command to compile toplevel code
	as well (when possible).
	* generic/tclCompile.c: added new instruction enums
	* generic/tclCompile.h: added debug info for new instructions
	* generic/tclExecute.c (TclExecuteByteCode): moved elemPtr to
	toplevel var (oft-used).  Added definitions for new bytecode
	instructions INST_LIST_INDEX, INST_LIST_LENGTH, INST_APPEND_SCALAR1,
	INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4,
	INST_APPEND_ARRAY_STK, INST_APPEND_STK, INST_LAPPEND_SCALAR1,
	INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4,
	INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK.
	Refactored repititious code for reuse with INST_LOAD_STK (same as
	INST_LOAD_SCALAR_STK), INST_STORE_STK (same as
	INST_STORE_SCALAR_STK).
	Updated INST_STR_CMP with style of fix of 2001-04-06 Fellows
	[Bug #219201] as that fix only affected the runtime eval'ed
	"string" (string compare is normally byte-compiled now).  We
	may want to back these out for speed in the future, noting the
	problems with \x00 comparisons in the docs.
	* generic/tclInt.h: declarations for new compile commands.
	* generic/tclVar.c: change TclGetIndexedScalar,
	TclGetElementOfIndexedArray, TclSetElementOfIndexedArray and
	TclSetIndexedScalar to use flags.  The Set functions now support
	TCL_APPEND_ELEMENT and TCL_LIST_ELEMENT as well.
	* generic/tclInt.decls:
	* generic/tclIntDecls.h: minor signature changes for above.

	* generic/tclCmdMZ.c: made use of new Tcl_GetUnicodeFromObj.

2001-05-16  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/console.n: Deleted.  Put it in the wrong source tree!  D'oh!

2001-05-15  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tcl.decls:
	* generic/tclDecls.h:
	* generic/tclStubInit.c:
	* generic/tclStringObj.c (Tcl_GetUnicodeFromObj): new function to
	parallel Tcl_GetStringFromObj (fix of an API oversight).

	* unix/tclUnixPipe.c: updated pipeChannelType to
	TCL_CHANNEL_VERSION_2 type specification.

	* tests/fileName.test: corrected tests not to fail on win when a
	C:/test dir exists.

	* generic/tclFileName.c (ExtractWinRoot): corrected ABR error

2001-05-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* tests/lindex.test: added test for nested braces [Patch: 423617]

2001-05-15  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclInt.h
	* generic/tclNamesp.c: invalidate all bytecodes in a namespace if
	a new command shadows a bytecoded command.
	* tests/namespace.test
	Patched from [Bug: 231259] 

2001-05-15  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/console.n: Created.  It seems very odd to me that the
	console implementation is part of the Tcl distribution and not
	part of Tk, but given the location of the source, the
	documentation must obviously match up...

2001-05-14  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCmdMZ.c (Tcl_StringObjCmd): 
	* tests/string.test (string-4.14): Negative string indices should
	not be added as offsets to the result of [string first] but
	instead be treated as referring to the start of the string.
	[Bug: 423581]

2001-05-11  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Add a LDFLAGS variable to the
	Makefile instead of directly substing @LDFLAGS@.
	* unix/configure: Regen.
	* unix/tcl.m4: Fix CFLAGS_DEFAULT so that the name
	of a Makefile variable is passed as @CFLAGS@.
	* win/Makefile.in: Move the setting of CFLAGS
	higher up in the Makefile.
	* win/configure: Regen.
	* win/configure.in: Use dnl to comment out macros
	so that they are not accidently expanded.
	* win/tcl.m4: Fix CFLAGS_DEFAULT so that the name
	of a Makefile variable is passed as @CFLAGS@.

2001-05-07  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclExecute.c: insure different rand() seeds in different
	threads [Bug 416643]

2001-05-03  Jeff Hobbs  <jeffh@ActiveState.com>

	* tests/tcltest.test: removed extraneous 'c' (doh!) [Bug: 414031]

	* tools/tcltk-man2html.tcl: removed use of 'exec' for portability
	and fixed up code.

2001-05-03  Don Porter  <dgp@users.sourceforge.net>

	* doc/library.n:
	* library/init.tcl:
	* tests/autoMkindex.t*: Modified [auto_import] to apply
	pattern matching in the [namespace import] style.  [Bug 420186]
	***POTENTIAL INCOMPATIBILITY*** for any callers of [auto_import]
	from outside Tcl that expect the pattern matching to be like that
	of [string match].

2001-05-03  Miguel Sofer  <msofer@users.sourceforge.net>

	* generic/tclParse.c: 
	* tests/namespace.test: Insure consistent behaviour of the
	[unknown] command: when a command is unknown, it is always
	processed by [::unknown], ignoring any namespace proc which
	happens to be called "unknown" [Patch #421166, Bug #420507]

2001-05-02  Don Porter  <dgp@users.sourceforge.net>

	* tools/genStubs.tcl: Add a package require of Tcl 8
	at the beginning of the script so that the script
	will print a descriptive error message when run
	in an old Tcl 7 shell.

2001-04-27  Kevin Kenny	<kennykb@crd.ge.com>

	* generic/tclInt.decls:
	* generic/tclInt.h:
	* generic/tclCmdIL.c:
	* generic/tclProc.c:
	* generic/tclVar.c: Added another collection of missing CONSTs
	related to TclGetNamespaceForQualName.
	* generic/tclIntDecls.h: Regenerated.
	
2001-04-25  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
	* unix/tclConfig.sh.in: Add TCL_THREADS variable.
	* win/configure: Regen.
	* win/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
	* win/tclConfig.sh.in: Add TCL_THREADS variable.

2001-04-25  Mo DeJong  <mdejong@redhat.com>

	* unix/configure: Regen.
	* unix/configure.in: Use $@ in MAKE_LIB and MAKE_STUB_LIB
	commands instead of using a delayed subst variable. Replace
	instances of STUB_LIB_FILE with TCL_STUB_LIB_FILE.

2001-04-25  Mo DeJong  <mdejong@redhat.com>

	* unix/Makefile.in: Use TCL_STUB_LIB_FILE instead of STUB_LIB_FILE.
	* unix/configure: Regen.
	* unix/configure.in: Don't subst STUB_LIB_FILE, use TCL_STUB_LIB_FILE
	instead.

2001-04-25  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tools/encoding/iso8859-15.txt:
	* library/encoding/iso8859-15.enc: Oops! Got the full encoding
	wrong.  Should be fixed now...

	* tools/encoding/iso8859-15.txt:
	* library/encoding/iso8859-15.enc:
	* tools/tcl.wse.in: Added ISO 8859-15 (a.k.a. Latin-1 + Euro
	currency symbol) support.

	* generic/tclNamesp.c:
	* generic/tclBasic.c (TclRenameCommand): Missing CONST from
	several declarations relating to use of TclGetNamespaceForQualName

2001-04-24  Kevin B. Kenny    <kennykb@acm.org>
	* doc/AssocData.3:
	* doc/CrtCommand.3:
	* doc/CrtMathFnc.3:
	* doc/CrtObjCmd.3:
	* doc/ExprLong.3:
	* generic/tclBasic.c:
	* generic/tclCmdMZ.c:
	* doc/CrtSlave.3:
	* generic/tclNamesp.c:
	* generic/tcl.decls:
	* generic/tcl.h:
	* generic/tclInt.decls:
	* generic/tclInt.h: (TIP #27) Another round of CONST changes, this
	time adding CONST to the API's exported from tclBasic.c.
	[Patch #415179]
	***POTENTIAL INCOMPATIBILITY*** from 8.4a2, in which Vince
	Darley's changes to command tracing were added.  A const has been
	added to the type signature of one of the parameters to
	Tcl_CommandTraceProc.

2001-04-10  Kevin B. Kenny    <kennykb@acm.org>
	* unix/tclUnixTime.c: Altered code to use memcpy instead of
	structure assigments in an effort to achieve better K&R
	compatibility.
	
2001-04-10  Kevin B. Kenny    <kennykb@acm.org>

	* unix/tclUnixTime.c: Fixed silly typo in calls to 'gmtime' and
	'localtime' that broke the Linux build.

2001-04-09  Kevin B. Kenny    <kennykb@acm.org>

	* unix/tclLoadShl.c: Added DYNAMIC_PATH to the load flags so that
	the SHLIB_PATH will be searched for other libraries.  [Bug #219140]
	
2001-04-09  Kevin B. Kenny    <kennykb@acm.org>

	* unix/tcl.m4: Added _REENTRANT to Solaris build so that thread
	safe library routines are included.
	* unix/configure: Re-ran 'autoconf' with changed tcl.m4
	* tclUnixTime.c: Modified for thread safety of 'gmtime' and
	'localtime' system calls [Bugs #219136 and #232558]
	
2001-04-09  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/expr.test (expr-21.*): Tests to check below fix.
	* generic/tclParseExpr.c (GetLexeme): Now recognises the
	non-numeric boolean literals for what they are. It no longer makes
	sense for anyone to create functions with the same name as one of
	them, but this was true in 7.* as well [Bug #217777; finally!]

2001-04-07  Miguel Sofer <msofer@users.sourceforge.net>

	* generic/tclExecute.c: Avoid panic when there are extra items in
	  the tcl stack [Bug #406709, Patch #414470]
	* tests/foreach.test: test to exercise the patch

2001-04-07  Miguel Sofer <msofer@users.sourceforge.net>

	* doc/namespace.n: document correct functionality
	* generic/tclNamesp.c: corrected behaviour of [namespace code]
	(Bug #219385, Patch #403530)
	* library/init.tcl:
	* tests/namespace-old.test: test correct functionality
	* tests/namespace.test: test correct functionality

2001-04-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/Makefile.in (checkdoc): New target, checking the
	  definitions as found in the compiled library against the
	  manpages to find undocumented public functionality.

	* unix/mkLinks: Updated to include the new manpage.

	* doc/UniCharIsAlpha.3: New manpage documenting the Unicode
	  character classification APIs [Bug #218720].

2001-04-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/mkLinks: Updated to incorporate the changes below.

	* doc/StringObj.3: Added 'Tcl_AttemptSetObjLength' to the NAME
	  section. [Bug #414435].

	* doc/Alloc.3: Added both 'Tcl_AttemptAlloc' and
	  'Tcl_AttemptRealloc' to the NAME section. [Bug #414435].

	* doc/Utf.3: Added both 'Tcl_UniCharCaseMatch' and
	  'Tcl_UniCharNcasecmp' to the NAME section. [Bug #414435].

2001-04-06  Don Porter  <dgp@users.sourceforge.net>

	* library/init.tcl:
	* tests/init.test:  Modified processing of $::errorInfo by
	[unknown] when the auto-loaded command throws an error to better
	cover the tracks of auto-loading.  [Bug 219280, Patch 403551]

2001-04-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/read.n: Added section on "USE WITH SERIAL PORTS" to resolve
	[Bug #219402]

	* tests/string.test (string-2.30): Test for this case
	* generic/tclCmdMZ.c (Tcl_StringObjCmd, STR_COMPARE branch): Fixed
	problem caused by Utf-rep of \x00 being more than Utf-rep of \x01
	fooling memcmp by forcing everything through Utf-based
	comparisons.  Added optimizations for case where objects have a
	string/unicode-rep or a bytearray-rep (i.e. where we can perform
	comparisons on fixed-size units.) [Bug #219201]
	* generic/tclUtf.c (Tcl_UtfNcmp): Corrected seriously erroneous
	comment.

2001-04-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* doc/Macintosh.3: Removed duplicates from .SH line
	  [Bug #413983]. 

2001-04-05  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCmdMZ.c (Tcl_StringObjCmd): Fixed so will compile
	with K&R compilers [Patch #413844, Bug #413847]

2001-04-04  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclMain.c:  Patch from Kevin Kenny to restore support of
	  pre-ANSI compilers.  [Bug 413846, Patch 413842]

2001-04-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/mkLinks: Updated to contain the new manpage.

	* doc/Environment.3: New manpage, describes Tcl_PutEnv
	  [Bug #219171]. 

	* doc/Macintosh.3: New manpage describing the macintosh specific
	  parts of the public API [Bug #219169].

2001-04-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* unix/configure:
	* unix/tcl.m4: extended test of termios vs. termio vs. sgtty to
	better detect result on Linux and when certain configure
	redirections are being used. (max) [Patch #402923; Bug #227412,
	#219194]

2001-04-04  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* generic/tclTest.c:
	* tests/io.tests: TIP #10 followup correcting a problem with the
	  original patch because of the lack of 'testthread id' for a
	  non-threaded compilation.

2001-04-04  Kevin Kenny <kennykb@acm.org>

	* doc/ByteArrObj.3:
	* doc/DumpActiveMemory.3:
	* doc/InitStubs.3:
	* doc/PkgRequire.3:
	* doc/StringObj.3:
	* generic/tcl.decls:
	* generic/tcl.h:
	* generic/tclBinary.c:
	* generic/tclCkalloc.c:
	* generic/tclDecls.h:
	* generic/tclListObj.c:
	* generic/tclObj.c:
	* generic/tclPkg.c:
	* generic/tclStringObj.c:
	* generic/tclStubLib.c:
	  (TIP#27) Changed a number of Tcl API's to accept "CONST char*"
	  in place of simple "char*". (kennykb) [Patch #404026]

2001-04-04  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclListObj.c (Tcl_SetListObj): set objPtr->length = 0 in
	empty object case to maintain sanctity of Tcl_Obj bytes/length
	pairing. (porter) [Patch #405998]

2001-04-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* unix/mkLinks: Added 'Signal.3', 'Tcl_WaitPid'.

	* doc/DetachPids.3: Added description of 'Tcl_WaitPid' [Bug #219173].

	* doc/Signal.3: New man page describing the public API procedures
	  'Tcl_SignalId' and 'Tcl_SignalMsg' [Bug #219172].

2001-04-02  Jeff Hobbs  <jeffh@ActiveState.com>

	* README:
	* win/README:
	* win/README.binary: further notes corrections.

	* win/configure:
	* win/tcl.m4 (SHLIB_LD):  added -incremental:no. [Bug #219381]

2001-04-01  Jeff Hobbs  <jeffh@ActiveState.com>

	* README:
	* mac/README:
	* win/README:
	* win/README.binary:
	* unix/README: updated patchlevel information to 8.4a3 and
	updated links and notes.

	* generic/tcl.h:
	* tools/tcl.wse.in:
	* win/configure.in (VER):
	* win/configure:
	* unix/configure:
	* unix/configure.in (VER):
	* unix/tcl.spec: updated patchlevel information to 8.4a3

2001-03-30  Jeff Hobbs  <jeffh@ActiveState.com>

	* generic/tclCkalloc.c (TclFinalizeMemorySubsystem): set curTagPtr
	to NULL to allow for reuse.
	* generic/tclEvent.c (Tcl_Finalize): moved the tsdPtr
	initialization inside the subsystemsInitialized check to prevent
	it potentially getting called twice during finalization.  (wu)
	[Patch #403532, Bug #219391]

	* generic/tclThreadTest.c (Tcl_ThreadObjCmd): cast fixes
	* generic/tclTest.c (TestChannelCmd): added cast to mollify
	Windows debug build.

	* win/tclWinSock.c (SocketEventProc): Fixed race condition in
	readability of socket on Windows.
	[Patch #410674, Bug #219205 #219333]

	* win/tcl.m4: added imm32.lib to LIBS_GUI for Tk IME support.

	* win/Makefile.in (install-libraries): removed extra \s that broke
	the target.
	(install-doc): improved install-* targets to use their base build
	dependency.

2001-03-30  Andreas Kupries  <andreas_kupries@users.sourceforge.net>

	* All of the changes below belong to TIP #10 [Tcl I/O Enhancement:
	  Thread-Aware Channels]. See also [Patch #403358] at SF.

	* generic/tclIO.h (struct ChannelState, line 236f): Extended the
	  structure with a new field of type 'Tcl_ThreadId' to hold the id
	  of the thread currently managing all channels with this state.

	  Note: This structure is shared by all channels in a stack of
	  transformations.

	* generic/tclIO.c (Tcl_CreateChannel, lines 1058-1065): Modified
	  to store the Id of the current thread in the 'ChannelState' of
	  the new channel.

	* generic/tclIO.c (Tcl_SpliceChannel, lines 2265-2270): Modified
	  in the same manner as 'Tcl_CreateChannel' as the channel will be
	  managed by the current thread afterward.

	* generic/tclIO.c   (Tcl_GetChannelThread, lines 1478-1503):
	* generic/tcl.decls (Tcl_GetChannelThread, lines 1504-1506): New
	  API function to retrieve the Id of the managing thread from a
	  channel. Implementation and declaration.

	* generic/tclTest.c (TestChannelCmd, lines 4520-4532): Added
	  subcommand 'mthread' to query a channel about its managing
	  thread.

2001-03-29  Mo DeJong  <mdejong@redhat.com>

	* tests/interp.test: Print out warning when
	testinterpdelete command is not defined.
	Add tests that checks to make sure a
	child interp inherits the parent's cwd.

2001-03-29  Jeff Hobbs  <jeffh@gimlet.activestate.com>

	* doc/tcltest.n: corrected incorrect macro usage.

	* doc/lsort.n: corrected unbalanced nroff macros.

	* unix/tclUnixPipe.c (TclpCreateTempFile): prevent potential race
	condition and security leak in tmp filename creation.
	(max) [Patch #402924]

	* unix/configure:
	* unix/tcl.m4: corrected IRIX-5.x config to not use -n32.
	(english) [Patch #403626]

	* unix/tclUnixThrd.c (Tcl_ConditionWait): fixed handling of
	timeout for threads (corrects excessive CPU usage issue for Tk on
	Unix in threaded Tcl environment). (ruppert) [Bug #411603]

2001-03-29  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/lsort.n: Added some notes that clarify the behaviour of
	[lsort] as well as a whole bunch of examples.  [Bug #219202]

2001-03-27  Jeff Hobbs  <jeffh@gimlet.activestate.com>

	* doc/Alloc.3: corrected docs to note that Tcl_Attempt* return
	char *'s, not ints. [Bug #411388]

	* tests/regexp.test (regexp-19.1):
	* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): fixed handling of nulls
	in subspec value.

2001-03-26  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclDecls.h (Tcl_InitCustomHashTable):  Correction to
	patch from 2001-01-18;  tclDecls.h was not generated using
	'make genstubs'.

2001-03-26  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* win/tclWinInt.h (tclWinTCharEncoding): Removed as now a static
	variable in win/tclWin32Dll.c instead.

2001-03-23  Jeff Hobbs  <jeffh@activestate.com>

	* generic/tclVar.c (Tcl_ArrayObjCmd): Corrected retrieval of
	resultPtr to prevent possible corruption.

	* generic/tclNamesp.c (Tcl_Import): Correctly freed a DString.
	(lavana) [Patch #403755]

2001-03-15  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/set-old.test (set-old-7.2): Changed error behaviour of
	[unset] to agree with documentation, so must change test as well.

2001-03-14  Don Porter  <dgp@users.sourceforge.net>

	* library/package.tcl (pkg_mkIndex):  Added patch from Vince
	Darley to make [pkg_mkIndex -verbose] even more verbose.
	[Bug 219349, Patch 403529]

2001-03-13  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* doc/info.n: Improved documentation for [info hostname].
	[Bug #403840]

	* generic/tclVar.c (Tcl_UnsetObjCmd): Made command behave as
	documented [issue remaining from bug #405769]

	* generic/tclCmdMZ.c (Tcl_StringObjCmd): A missing
	{return TCL_OK;} was causing memory corruption.  [Bug #408002]

	* generic/tclExecute.c (TclDeleteExecEnv, GrowEvaluationStack,
	TclExecuteByteCode): Added some casts to ClientData that are
	apparently needed on some architectures.

2001-03-12  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/string.test: Fixed some test numberings and added a test.
	[Patch #403229]

2001-03-06  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to
	avoid a read off the end of the argument array that could occur
	when executing something like [unset -nocomplain] was executed.
	Improved the error message given when too few arguments are given
	(-nocomplain should obviously be *before* --, not after it) and
	also modified the test suite to take account of that and the
	documentation to use the same improvement. [Bug 405769]

2001-03-02  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclExecute.c (TclExecuteByteCode): Fixed bug that could
	pass pointers to freed memory to command implementations, which
	most obviously caused some weird behaviour with [info level], but
	could have caused problems with user code and command traces too.
	[Bug 404865, Patch 405436]

2001-02-23  msofer  <msofer@users.sourceforge.net>
	* no changes; fixing up the missing comment in the previous one.
	Sorry.

2001-02-23  msofer  <msofer@ant.utdt>

	* /cvsroot/tcl/tcl/tests/execute.test:
	added test for evaluation of an expression in a variable; evals once
	by compiling, second time using the previous compilation

2001-02-18  Kevin B. Kenny  <kennykb@acm.org>

	* doc/clock.n: Updated documentation to reflect the addition of
	compat/strftime.c, including the correct formatting of
	ISO-8601:1988 fiscal week number (%V).
	
2001-02-15  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* generic/tclCmdMZ.c (Tcl_SplitObjCmd): Improved efficiency of
	splitting strings into individual characters by adding hash so
	that only one Tcl_Obj per character is created.  Improves
	performance of splitting of short strings and makes a huge
	difference to splitting of long strings, such as is done in the
	mime package in tcllib.  [Bug #131523]

2001-01-31  Don Porter  <dgp@users.sourceforge.net>

	* win/makefile.vc (install-libraries):  Corrected misdirected
	install directory for the msgcat 1.2 package.

2001-01-30  Don Porter  <dgp@users.sourceforge.net>

	* generic/tclIO.c (CopyData): Moved code that updates the count
	of how many bytes are left to copy.  Corrects bug that when
	writing occurs in the background, the copy loop could be
	escaped without updating the count, causing CopyData() to try
	to copy more bytes than the toRead value originally passed to
	TclCopyChannel(), leading to hangs and misreporting of number
	of bytes copied. [Bug 118203, Patch 103432]

2001-01-18  Andreas Kupries  <a.kupries@westend.com>

	* Everything below belongs together, it fixes bug #123153.

	* generic/tcl.h (line 342): A bit more explanation about the
	  default value for TCL_PRESERVE_BINARY_COMPATABILITY.

	* generic/tcl.h (line 1208): Define the macro 'Tcl_InitHashTable'
	  only when TCL_PRESERVE_BINARY_COMPATIBILITY is not set
	  as it kills binary compatibility to 8.3 and earlier
	  versions. This is the main part of the patch/change.

	* generic/tcl.decls (line 1469):
	* generic/tclHash.c (Tcl_InitHashTable):
	* generic/tclHash.c (Tcl_InitHashTableEx):
	* generic/tclObj.c (Tcl_InitObjHashTable): Changed
	  'Tcl_InitHashTableEx' to 'Tcl_InitCustomHashTable'. This change
	  is more of an estethical nature, replacing the ubiquitous 'Ex'
	  suffix with a more meaningful name. The introduced binary
	  incompatibility is deemed acceptable as it is between alpha
	  versions.  Updated callers.

	* doc/Hash.3:
	* unix/mkLinks: Changed 'Tcl_InitHashTableEx' to
	  'Tcl_InitCustomHashTable'.

2001-01-10  Donal K. Fellows  <fellowsd@cs.man.ac.uk>

	* tests/winPipe.test (winpipe-1.20): 
	* tests/winDde.test (createChildProcess): 
	* tests/pkgMkIndex.test (pkgtest::createIndex):  Removed
	assumption that paths contain no spaces which causes problems with
	both [eval] and [open |...] due to the well-known differences
	between lists and strings.  Fixes bug #119406

2001-01-04  Don Porter  <dgp@users.sourceforge.net>

	* tests/unixInit.test:
	* unix/tclUnixInit.c (TclpInitLibraryPath):
	* win/tclWinInit.c (TclpInitLibraryPath):  Several entries in
	the library path ($tcl_libPath) are determined relative to the
	absolute path of the executable.  When the executable is
	installed in or near the root directory of the file system,
	relative pathnames were being incorrectly generated, and in
	the worst case, memory access violations were crashing the program.
	[Bug 119416, Patch 102972]

	******************************************************************
	*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000"             ***
	*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
	******************************************************************
Changes to README.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
README:  Tcl
    This is the Tcl 8.4a5 source distribution.
    Tcl/Tk is also available through NetCVS:
	http://tcl.sourceforge.net/
    You can get any source release of Tcl from the file distributions
    link at the above URL.

RCS: @(#) $Id: README,v 1.39.8.1 2002/06/10 05:33:07 wolfsuit Exp $

Contents
--------
    1. Introduction
    2. Documentation
    3. Compiling and installing Tcl
    4. Development tools

|





|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
README:  Tcl
    This is the Tcl 8.4b3 source distribution.
    Tcl/Tk is also available through NetCVS:
	http://tcl.sourceforge.net/
    You can get any source release of Tcl from the file distributions
    link at the above URL.

RCS: @(#) $Id: README,v 1.39.8.2 2002/08/20 20:25:24 das Exp $

Contents
--------
    1. Introduction
    2. Documentation
    3. Compiling and installing Tcl
    4. Development tools
Changes to changes.
1
2
3
4
5
6
7
8
9
10
Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.62.8.1 2002/06/10 05:33:07 wolfsuit 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


|







1
2
3
4
5
6
7
8
9
10
Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.62.8.2 2002/08/20 20:25:24 das Exp $

1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.

2. Semi-colon now available for grouping commands on a line.

3. For a command to span multiple lines, must now use backslash-return
5434
5435
5436
5437
5438
5439
5440













































































































        *** POTENTIAL INCOMPATIBILITY ***

2002-03-04 (bug fix)[474358, 218099, 219314, 524674] fixed several problems
related to the handling of iso2022 text and finalization of escape-based
encodings. (taguchi, takahashi, hobbs)

--- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---




















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
        *** POTENTIAL INCOMPATIBILITY ***

2002-03-04 (bug fix)[474358, 218099, 219314, 524674] fixed several problems
related to the handling of iso2022 text and finalization of escape-based
encodings. (taguchi, takahashi, hobbs)

--- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---

2002-03-06 (new feature)[TIP 80] expanded [lsearch] options (wilkason, fellows)

2002-03-07 (new feature)[TIP 87] [interp recursionlimit] (trier)

2002-03-08 (platform feature) mingw 1.1 build favored (dejong)

2002-03-20 (new feature)[TIP 27] CONST-ified variable access functions (porter)

2002-03-24 (bug fix)[511666,511658,523217,530960] expanded
Tcl_FSMatchInDirectory to handle assorted [glob] bugs in VFS. (darley)
        *** POTENTIAL INCOMPATIBILITY with prior 8.4a releases ***

2002-03-25 (bug fix)[495726] stopped tcltest disabling of auto-loading (porter)

2002-03-25 (bug fix)[495977] allow \n in test constraints (porter)

2002-03-27 (platform support)[527941,533862] VC/winhelp/W9X (spjuth,
gravereaux)

2002-03-28 (bug fix)[219181] exception at level 0 issues (sofer)

2002-03-28 (bug fix)[219362] command termination; Tcl_CreateTrace (knoll,sofer)

2002-04-05 (bug fix)[536879] exceptions during variable subst (porter)

2002-04-15 (bug fix)[497446,513983] tcltest syntax errors now raised (porter)
	***POTENTIAL INCOMPATIBILITY with prior tcltest 2.0.* (8.4aX)***

2002-04-17 (bug fix)[495660] [(save|restore)state] deprecated (porter)

2002-04-17 (bug fix)[526524] escape-based encodings corrected (yamamoto, hobbs)

2002-04-18 (bug fix)[542588] [expr] error msgs improved (ehrens, sofer)

2002-04-18 (bug fix)[545325] [info level $level] now returns [namespace eval]
as documented (suchenwirth,sofer)

2002-04-19 (bug fix)[544727] export [mcload]; ns context of [mcmax] (porter)
=> msgcat 1.2.3

2002-04-22 (performance enhancement) threaded memory allocator (AOL, hobbs)

2002-04-24 (new feature) TCLTK_NO_LIBRARY_TEXT_RESOURCES #define disables
inclusion of tcl library code in resource fork on Mac.  (steffen)

2002-05-21 (platform support) static libs on OSF (dejong)

2002-05-24 (bug fix)[557878] set encoding on listening socket (staplin,
kupries)

2002-05-24 (new feature)[TIP 91] Tcl_Seek compatibility (fellows)

2002-05-28 (bug fix)[545579] VFS [load] left temp file (darley)

2002-05-28 (bug fix)[559376] plug timezone env leak on Windows (hobbs)

2002-05-29 (performance enhancement) [string compare] optimized (hobbs,fellows)

2002-05-31 (bug fix)[550534] plug interp leak in [pkg_mkIndex] (helmut)

2002-05-31 (dead code)[474335,555635] removed all use of matherr() (english)
        *** POTENTIAL INCOMPATIBILITY ***

2002-06-04 (new feature)[TIP 85,521362] custom result match in tcltest
(markus, porter)
=> tcltest 2.1

2002-06-06 (bug fix)[524352] encoding, threading, and environment issues on
MacOSX (steffen)

2002-06-06 (bug fix)[512214,558742,512214,461000] lazy initialization of
tcltest constraints (porter)

2002-06-07 (bug fix)[563122,564595] EOVERFLOW definitions (fellows)

2002-06-11 (bug fix)[567386] [info locals] corrections (sofer)

2002-06-14 (new feature)[TIP 102] [trace list] renamed [trace info] (fellows)

2002-06-17 (new feature)[525522,525525] msgcat support for XPG4 locales;
examination of LC_ALL, LC_MESSAGES environment variables (haible, porter)
=> msgcat 1.3

2002-06-17 (new feature)[565088] header files assume modern C compiler by
default; older compilers may need configuration (english)
        *** POTENTIAL INCOMPATIBILITY ***

2002-06-17 (bug fix)[554068] [exec] argument quoting on Windows (darley)

2002-06-17 (new feature)[TIP 62,462580] command execution traces (lavana)

2002-06-19 (bug fix)[558324] regexp sets a linked variable (watson)

 * (performance enhancment) optimizations of bytecode execution (sofer)

2002-06-21 (new feature)[TIP 99,562970] new [file link] command (darley)

2002-06-24 (new feature)[TIP 101] new [tcltest::configure] command (porter)

2002-06-25 (new feature) --enable-man-symlinks and --enable-man-compression
options to configure (max)

2002-06-26 (bug fix)[565880] [clock format] now respects locale (max)
        *** POTENTIAL INCOMPATIBILITY ***

2002-07-03 (bug fix)[577015] [catch] catches even compile errors (sofer)

--- Released 8.4b1, July 5, 2002 --- See ChangeLog for details ---
Changes to doc/Access.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Access.3,v 1.4.8.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Access, Tcl_Stat \- check file permissions and other attributes
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Access.3,v 1.4.8.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Access, Tcl_Stat \- check file permissions and other attributes
.SH SYNOPSIS
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
\fBTcl_Stat\fR, wherever possible.
.PP
There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR
rather than calling system level functions \fBaccess\fR and \fBstat\fR
directly.  First, the Windows implementation of both functions fixes
some bugs in the system level calls.  Second, both \fBTcl_Access\fR
and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook
into a linked list of functions.  This allows the possibity to reroute
file access to alternative media or access methods.
.PP
\fBTcl_Access\fR checks whether the process would be allowed to read,
write or test for existence of the file (or other file system object)
whose name is pathname.   If pathname is a symbolic link on Unix,
then permissions of the file referred by this symbolic link are
tested.
.PP
On success (all requested permissions granted), zero is returned.  On
error (at least one bit in mode asked for a permission that is denied,
or some other  error occurred), -1 is returned.
.PP
\fBTcl_Stat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file.  You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file.  The stat structure
includes info regarding device, inode (always 0 on Windows),
priviledge mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and creation
time.
.PP
If \fIpath\fR exists, \fBTcl_Stat\fR returns 0 and the stat structure
is filled with data.  Otherwise, -1 is returned, and no stat info is
given.

.SH KEYWORDS
stat, access








|

















|











40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
\fBTcl_Stat\fR, wherever possible.
.PP
There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR
rather than calling system level functions \fBaccess\fR and \fBstat\fR
directly.  First, the Windows implementation of both functions fixes
some bugs in the system level calls.  Second, both \fBTcl_Access\fR
and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook
into a linked list of functions.  This allows the possibility to reroute
file access to alternative media or access methods.
.PP
\fBTcl_Access\fR checks whether the process would be allowed to read,
write or test for existence of the file (or other file system object)
whose name is pathname.   If pathname is a symbolic link on Unix,
then permissions of the file referred by this symbolic link are
tested.
.PP
On success (all requested permissions granted), zero is returned.  On
error (at least one bit in mode asked for a permission that is denied,
or some other  error occurred), -1 is returned.
.PP
\fBTcl_Stat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file.  You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file.  The stat structure
includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and creation
time.
.PP
If \fIpath\fR exists, \fBTcl_Stat\fR returns 0 and the stat structure
is filled with data.  Otherwise, -1 is returned, and no stat info is
given.

.SH KEYWORDS
stat, access

Changes to doc/AddErrInfo.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.5.14.1 2002/02/05 02:21:57 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AddObjErrorInfo, Tcl_AddErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- record information about errors
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: AddErrInfo.3,v 1.5.14.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_AddObjErrorInfo, Tcl_AddErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- record information about errors
.SH SYNOPSIS
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
This variable \fBerrorCode\fR will be set to this value.
.AP char *element in
String to record as one element of \fBerrorCode\fR variable.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP "CONST char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "CONST char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first NULL byte







|







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
If negative, all bytes up to the first null byte are used.
.AP Tcl_Obj *errorObjPtr in
This variable \fBerrorCode\fR will be set to this value.
.AP char *element in
String to record as one element of \fBerrorCode\fR variable.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.AP "CONST char" *script in
Pointer to first character in script containing command (must be <= command)
.AP "CONST char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first NULL byte
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
in \fBerrorCode\fR).
It may be convenient to include this string as part of the
error message returned to the application in
the interpreter's result.
.PP
\fBTcl_LogCommandInfo\fR is invoked after an error occurs in an
interpreter.  It adds information about the command that was being
executed when the error occured to the \fBerrorInfo\fR variable, and
the line number stored internally in the interpreter is set.  On the
first call to \fBTcl_LogCommandInfo\fR or \fBTcl_AddObjErrorInfo\fR
since an error occurred, the old information in \fBerrorInfo\fR is
deleted.
.PP
It is important to call the procedures described here rather than
setting \fBerrorInfo\fR or \fBerrorCode\fR directly with







|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
in \fBerrorCode\fR).
It may be convenient to include this string as part of the
error message returned to the application in
the interpreter's result.
.PP
\fBTcl_LogCommandInfo\fR is invoked after an error occurs in an
interpreter.  It adds information about the command that was being
executed when the error occurred to the \fBerrorInfo\fR variable, and
the line number stored internally in the interpreter is set.  On the
first call to \fBTcl_LogCommandInfo\fR or \fBTcl_AddObjErrorInfo\fR
since an error occurred, the old information in \fBerrorInfo\fR is
deleted.
.PP
It is important to call the procedures described here rather than
setting \fBerrorInfo\fR or \fBerrorCode\fR directly with
Changes to doc/Alloc.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Alloc.3,v 1.5.12.1 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Alloc.3,v 1.5.12.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory
.SH SYNOPSIS
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that
\fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl
interpreter to \fBpanic\fR if the memory allocation fails.  If the
allocation fails, these functions will return NULL.
.PP
The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR,
\fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented
as macros.  Normally, they are synonyms for the correponding
procedures documented on this page.  When Tcl and all modules
calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however,
these macros are redefined to be special debugging versions of 
of these procedures.  To support Tcl's memory debugging within a
module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc.

.SH KEYWORDS
alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG







|








75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that
\fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl
interpreter to \fBpanic\fR if the memory allocation fails.  If the
allocation fails, these functions will return NULL.
.PP
The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR,
\fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented
as macros.  Normally, they are synonyms for the corresponding
procedures documented on this page.  When Tcl and all modules
calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however,
these macros are redefined to be special debugging versions of 
of these procedures.  To support Tcl's memory debugging within a
module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc.

.SH KEYWORDS
alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG
Changes to doc/Backslash.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Backslash.3,v 1.3 1999/04/16 00:46:30 stanton 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Backslash.3,v 1.3.28.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Backslash \- parse a backslash sequence
.SH SYNOPSIS
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

.SH DESCRIPTION
.PP
.VS 8.1
The use of \fBTcl_Backslash\fR is deprecated in favor of
\fBTcl_UtfBackslash\fR.
.PP
This is a utility procedure provided for backwards compatibilty with
non-internationalized Tcl extensions.  It parses a backslash sequence and
returns the low byte of the Unicode character corresponding to the sequence. 
.VE
\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of
characters in the backslash sequence.
.PP
See the Tcl manual entry for information on the valid backslash sequences.







|







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

.SH DESCRIPTION
.PP
.VS 8.1
The use of \fBTcl_Backslash\fR is deprecated in favor of
\fBTcl_UtfBackslash\fR.
.PP
This is a utility procedure provided for backwards compatibility with
non-internationalized Tcl extensions.  It parses a backslash sequence and
returns the low byte of the Unicode character corresponding to the sequence. 
.VE
\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of
characters in the backslash sequence.
.PP
See the Tcl manual entry for information on the valid backslash sequences.
Changes to doc/BoolObj.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: BoolObj.3,v 1.2 1998/09/14 18:39:46 stanton Exp $
'\" 
.so man.macros
.TH Tcl_BooleanObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- manipulate Tcl objects as boolean values
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: BoolObj.3,v 1.2.34.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_BooleanObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- manipulate Tcl objects as boolean values
.SH SYNOPSIS
71
72
73
74
75
76
77






78
79
80
81
82
83
If an error occurs during conversion, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR
and stores the boolean value in the address given by \fIboolPtr\fR.
If the object is not already a boolean object,
the conversion will free any old internal representation.







.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult

.SH KEYWORDS
boolean, boolean object, boolean type, internal representation, object, object type, string representation







>
>
>
>
>
>






71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
If an error occurs during conversion, it returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR
and stores the boolean value in the address given by \fIboolPtr\fR.
If the object is not already a boolean object,
the conversion will free any old internal representation.
Objects having a string representation equal to any of \fB0\fR,
\fBfalse\fR, \fBno\fR, or \fBoff\fR have a boolean value 0; if the
string representation is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or
\fBon\fR the boolean value is 1.
Any of these string values may be abbreviated, and upper-case spellings
are also acceptable.

.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult

.SH KEYWORDS
boolean, boolean object, boolean type, internal representation, object, object type, string representation
Changes to doc/CmdCmplt.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CmdCmplt.3,v 1.2 1998/09/14 18:39:46 stanton Exp $
'\" 
.so man.macros
.TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CommandComplete \- Check for unmatched braces in a Tcl command
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_CommandComplete\fR(\fIcmd\fR)
.SH ARGUMENTS
.AS char *cmd
.AP char *cmd in
Command string to test for completeness.
.BE

.SH DESCRIPTION
.PP
\fBTcl_CommandComplete\fR takes a Tcl command string
as argument and determines whether it contains one or more







|













|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CmdCmplt.3,v 1.2.34.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CommandComplete \- Check for unmatched braces in a Tcl command
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_CommandComplete\fR(\fIcmd\fR)
.SH ARGUMENTS
.AS "CONST char" *cmd
.AP "CONST char" *cmd in
Command string to test for completeness.
.BE

.SH DESCRIPTION
.PP
\fBTcl_CommandComplete\fR takes a Tcl command string
as argument and determines whether it contains one or more
Changes to doc/Concat.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Concat.3,v 1.3.2.1 2002/02/05 02:21:57 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Concat \- concatenate a collection of strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
char *
\fBTcl_Concat\fR(\fIargc, argv\fR)
.SH ARGUMENTS
.AP int argc in
Number of strings.
.AP "CONST char * CONST" argv[] in
Array of strings to concatenate.  Must have \fIargc\fR entries.
.BE







|










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Concat.3,v 1.3.2.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Concat \- concatenate a collection of strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
CONST char *
\fBTcl_Concat\fR(\fIargc, argv\fR)
.SH ARGUMENTS
.AP int argc in
Number of strings.
.AP "CONST char * CONST" argv[] in
Array of strings to concatenate.  Must have \fIargc\fR entries.
.BE
Changes to doc/CrtChannel.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1997-2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtChannel.3,v 1.11.4.2 2002/06/10 05:33:08 wolfsuit Exp $
.so man.macros
.TH Tcl_CreateChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1997-2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: CrtChannel.3,v 1.11.4.3 2002/08/20 20:25:24 das Exp $
.so man.macros
.TH Tcl_CreateChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels
.SH SYNOPSIS
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
buffers for the stack of channels the supplied channel is part of.
.PP
.VS 8.4
\fBTcl_IsChannelShared\fR checks the refcount of the specified
\fIchannel\fR and returns whether the \fIchannel\fR was shared among
multiple interpreters (result == 1) or not (result == 0).
.PP
\fBTcl_IsChannelRegistered\fR checks wether the specified \fIchannel\fR is
registered in the given \fIinterp\fRreter (result == 1) or not
(result == 0).
.PP
\fBTcl_IsChannelExisting\fR checks wether 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.







|



|







270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
buffers for the stack of channels the supplied channel is part of.
.PP
.VS 8.4
\fBTcl_IsChannelShared\fR checks the refcount of the specified
\fIchannel\fR and returns whether the \fIchannel\fR was shared among
multiple interpreters (result == 1) or not (result == 0).
.PP
\fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is
registered in the given \fIinterp\fRreter (result == 1) or not
(result == 0).
.PP
\fBTcl_IsChannelExisting\fR checks whether a channel with the specified
name is registered in the (thread)-global list of all channels (result
== 1) or not (result == 0).
.PP
\fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the
(thread)global list of all channels (of the current thread).
Application to a channel still registered in some interpreter
is not allowed.
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
.PP
This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns
a pointer to the function.

.SH HANDLERPROC
.PP
The \fIhandlerProc\fR field contains the address of a function called by
the generic layer to notify the channel that an event occured.  It should
be defined for stacked channel drivers that wish to be notified of events
that occur on the underlying (stacked) channel.
\fIHandlerProc\fR should match the following prototype:
.PP
.CS
typedef int Tcl_DriverHandlerProc(
	ClientData \fIinstanceData\fR,
	int \fIinterestMask\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created.  The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occured 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







|













|







756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
.PP
This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns
a pointer to the function.

.SH HANDLERPROC
.PP
The \fIhandlerProc\fR field contains the address of a function called by
the generic layer to notify the channel that an event occurred.  It should
be defined for stacked channel drivers that wish to be notified of events
that occur on the underlying (stacked) channel.
\fIHandlerProc\fR should match the following prototype:
.PP
.CS
typedef int Tcl_DriverHandlerProc(
	ClientData \fIinstanceData\fR,
	int \fIinterestMask\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created.  The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
.PP
This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns
a pointer to the function.

.SH TCL_BADCHANNELOPTION
.PP
This procedure generates a "bad option" error message in an
Changes to doc/CrtCommand.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtCommand.3,v 1.4 2001/04/24 20:59:17 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtCommand.3,v 1.4.12.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateCommand \- implement new commands in C
.SH SYNOPSIS
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
\fIProc\fR should have arguments and result that match the type
\fBTcl_CmdProc\fR:
.CS
typedef int Tcl_CmdProc(
	ClientData \fIclientData\fR,
	Tcl_Interp *\fIinterp\fR,
	int \fIargc\fR,
	char *\fIargv\fR[]);
.CE
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
parameters will be copies of the \fIclientData\fR and \fIinterp\fR
arguments given to \fBTcl_CreateCommand\fR.
Typically, \fIclientData\fR points to an application-specific
data structure that describes what to do when the command procedure
is invoked.  \fIArgc\fR and \fIargv\fR describe the arguments to







|







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
\fIProc\fR should have arguments and result that match the type
\fBTcl_CmdProc\fR:
.CS
typedef int Tcl_CmdProc(
	ClientData \fIclientData\fR,
	Tcl_Interp *\fIinterp\fR,
	int \fIargc\fR,
	CONST char *\fIargv\fR[]);
.CE
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
parameters will be copies of the \fIclientData\fR and \fIinterp\fR
arguments given to \fBTcl_CreateCommand\fR.
Typically, \fIclientData\fR points to an application-specific
data structure that describes what to do when the command procedure
is invoked.  \fIArgc\fR and \fIargv\fR describe the arguments to
Changes to doc/CrtInterp.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtInterp.3,v 1.5.18.1 2002/02/05 02:21:57 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtInterp.3,v 1.5.18.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters
.SH SYNOPSIS
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
\fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and
\fBTcl_Release\fR should be wrapped around all uses of the interpreter.
Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR
has been called. To ensure that the interpreter is properly deleted when
it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other
code already called \fBTcl_DeleteInterp\fR; if not, call
\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code.
Do not call \fBTcl_DeleteInterp\fR on an interpreter for which
\fBTcl_InterpDeleted\fR returns nonzero.
.TP
Retrieving An Interpreter From A Data Structure
When an interpreter is retrieved from a data structure (e.g. the client
data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR,
\fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of
calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around
all uses of the interpreter; it is unsafe to reuse the interpreter once







<
<







99
100
101
102
103
104
105


106
107
108
109
110
111
112
\fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and
\fBTcl_Release\fR should be wrapped around all uses of the interpreter.
Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR
has been called. To ensure that the interpreter is properly deleted when
it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other
code already called \fBTcl_DeleteInterp\fR; if not, call
\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code.


.TP
Retrieving An Interpreter From A Data Structure
When an interpreter is retrieved from a data structure (e.g. the client
data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR,
\fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of
calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around
all uses of the interpreter; it is unsafe to reuse the interpreter once
Changes to doc/CrtSlave.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtSlave.3,v 1.5.12.1 2002/02/05 02:21:57 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtSlave.3,v 1.5.12.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands.
.SH SYNOPSIS
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "CONST char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP int argc in
Count of additional arguments to pass to the alias command.
.AP "char * CONST" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP int objc in
Count of additional object arguments to pass to the alias object command.
.AP Tcl_Object **objv in
Vector of Tcl_Obj structures, the additional object argumenst to pass to
the alias object command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target
command is defined for an alias.
.AP "CONST char" **targetCmdPtr out
Pointer to location to store the address of the name of the target command
for an alias.
.AP int *argcPtr out
Pointer to location to store count of additional arguments to be passed to
the alias. The location is in storage owned by the caller.
.AP char ***argvPtr out
Pointer to location to store a vector of strings, the additional arguments
to pass to an alias. The location is in storage owned by the caller, the
vector of strings is owned by the called function.
.AP int *objcPtr out
Pointer to location to store count of additional object arguments to be
passed to the alias. The location is in storage owned by the caller.
.AP Tcl_Obj ***objvPtr out







|





|











|







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
.AP "CONST char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP int argc in
Count of additional arguments to pass to the alias command.
.AP "CONST char * CONST" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP int objc in
Count of additional object arguments to pass to the alias object command.
.AP Tcl_Object **objv in
Vector of Tcl_Obj structures, the additional object arguments to pass to
the alias object command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target
command is defined for an alias.
.AP "CONST char" **targetCmdPtr out
Pointer to location to store the address of the name of the target command
for an alias.
.AP int *argcPtr out
Pointer to location to store count of additional arguments to be passed to
the alias. The location is in storage owned by the caller.
.AP "CONST char" ***argvPtr out
Pointer to location to store a vector of strings, the additional arguments
to pass to an alias. The location is in storage owned by the caller, the
vector of strings is owned by the called function.
.AP int *objcPtr out
Pointer to location to store count of additional object arguments to be
passed to the alias. The location is in storage owned by the caller.
.AP Tcl_Obj ***objvPtr out
227
228
229
230
231
232
233
234
235
For a description of the Tcl interface to multiple interpreters, see
\fIinterp(n)\fR.
.SH "SEE ALSO"
interp

.SH KEYWORDS
alias, command, exposed commands, hidden commands, interpreter, invoke,
master, slave, 








|
<
227
228
229
230
231
232
233
234

For a description of the Tcl interface to multiple interpreters, see
\fIinterp(n)\fR.
.SH "SEE ALSO"
interp

.SH KEYWORDS
alias, command, exposed commands, hidden commands, interpreter, invoke,
master, slave

Changes to doc/CrtTrace.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtTrace.3,v 1.2.34.1 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
.SH SYNOPSIS








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: CrtTrace.3,v 1.2.34.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
.SH SYNOPSIS
25
26
27
28
29
30
31
32

33
34
35

36
37
38
39
40
41
42
.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
.AS Tcl_CmdObjTraceDeleteProc (clientData)()
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP int level in
Only commands at or below this nesting level will be traced.  1 means

top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.

.AP int flags in
Flags governing the trace execution.  See below for details.
.AP Tcl_CmdObjTraceProc *objProc in
Procedure to call for each command that's executed.  See below for
details of the calling sequence.
.AP Tcl_CmdTraceProc *proc in
Procedure to call for each command that's executed.  See below for







|
>



>







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
.AS Tcl_CmdObjTraceDeleteProc (clientData)()
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP int level in
Only commands at or below this nesting level will be traced unless
0 is specified.  1 means
top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.
A value of 0 means that commands at any level are traced.
.AP int flags in
Flags governing the trace execution.  See below for details.
.AP Tcl_CmdObjTraceProc *objProc in
Procedure to call for each command that's executed.  See below for
details of the calling sequence.
.AP Tcl_CmdTraceProc *proc in
Procedure to call for each command that's executed.  See below for
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
	ClientData \fIclientData\fR,
	Tcl_Interp *\fIinterp\fR,
	int \fIlevel\fR,
	char *\fIcommand\fR,
	Tcl_CmdProc *\fIcmdProc\fR,
	ClientData \fIcmdClientData\fR,
	int \fIargc\fR,
	char *\fIargv\fR[]);
.CE
The parameters to the \fIproc\fR callback are similar to those of the
\fIobjProc\fR callback above. The \fIcommandToken\fR is
replaced with \fIcmdProc\fR, a pointer to the (string-based) command
procedure that will be invoked; and \fIcmdClientData\fR, the client
data that will be passed to the procedure.  The \fIobjc\fR parameter
is replaced with an \fIargv\fR parameter, that gives the arguments to







|







161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
	ClientData \fIclientData\fR,
	Tcl_Interp *\fIinterp\fR,
	int \fIlevel\fR,
	char *\fIcommand\fR,
	Tcl_CmdProc *\fIcmdProc\fR,
	ClientData \fIcmdClientData\fR,
	int \fIargc\fR,
	CONST char *\fIargv\fR[]);
.CE
The parameters to the \fIproc\fR callback are similar to those of the
\fIobjProc\fR callback above. The \fIcommandToken\fR is
replaced with \fIcmdProc\fR, a pointer to the (string-based) command
procedure that will be invoked; and \fIcmdClientData\fR, the client
data that will be passed to the procedure.  The \fIobjc\fR parameter
is replaced with an \fIargv\fR parameter, that gives the arguments to
Changes to doc/Encoding.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997-1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Encoding.3,v 1.7.18.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings.
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997-1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Encoding.3,v 1.7.18.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings.
.SH SYNOPSIS
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
If you planned to use the same "char" based interfaces on both Windows
95 and Windows NT, you could use \fBTcl_UtfToExternal\fR and
\fBTcl_ExternalToUtf\fR (or their \fBTcl_DString\fR equivalents) with an
encoding of NULL (the current system encoding).  On the other hand,
if you planned to use the Unicode interface when running on Windows NT
and the "char" interfaces when running on Windows 95, you would have
to perform the following type of test over and over in your program
(as represented in psuedo-code):
.CS
if (running NT) {
    encoding <- Tcl_GetEncoding("unicode");
    nativeBuffer <- Tcl_UtfToExternal(encoding, utfBuffer);
    Tcl_FreeEncoding(encoding);
} else {
    nativeBuffer <- Tcl_UtfToExternal(NULL, utfBuffer);







|







240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
If you planned to use the same "char" based interfaces on both Windows
95 and Windows NT, you could use \fBTcl_UtfToExternal\fR and
\fBTcl_ExternalToUtf\fR (or their \fBTcl_DString\fR equivalents) with an
encoding of NULL (the current system encoding).  On the other hand,
if you planned to use the Unicode interface when running on Windows NT
and the "char" interfaces when running on Windows 95, you would have
to perform the following type of test over and over in your program
(as represented in pseudo-code):
.CS
if (running NT) {
    encoding <- Tcl_GetEncoding("unicode");
    nativeBuffer <- Tcl_UtfToExternal(encoding, utfBuffer);
    Tcl_FreeEncoding(encoding);
} else {
    nativeBuffer <- Tcl_UtfToExternal(NULL, utfBuffer);
Changes to doc/Eval.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.9.14.1 2002/02/05 02:21:57 wolfsuit 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








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Eval.3,v 1.9.14.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts
.SH SYNOPSIS
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
.AP Tcl_Obj **objv in
Points to an array of pointers to objects; each object holds the
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any
null terminating character.  If \-1, then all characters up to the
first null byte are used.
.AP char *script in
Points to first byte of script to execute (NULL terminated and UTF-8).
This script must be in writable memory: temporary modifications are made
to it during parsing.
.AP char *string in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE








|

<
<







62
63
64
65
66
67
68
69
70


71
72
73
74
75
76
77
.AP Tcl_Obj **objv in
Points to an array of pointers to objects; each object holds the
value of a single word in the command to execute.
.AP int numBytes in
The number of bytes in \fIscript\fR, not including any
null terminating character.  If \-1, then all characters up to the
first null byte are used.
.AP "CONST char" *script in
Points to first byte of script to execute (NULL terminated and UTF-8).


.AP char *string in
String forming part of a Tcl script.
.AP va_list argList in
An argument list which must have been initialised using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
.BE

115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
\fIobjv\fR.  \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
.PP
\fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to
be executed is supplied as a string instead of an object and no compilation
occurs.  The string should be a proper UTF-8 string as converted by
\fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known
to possibly contain upper ascii characters who's possible combinations
might be a UTF-8 special code.  The string is parsed and executed directly
(using \fBTcl_EvalObjv\fR) instead of compiling it and executing the
bytecodes.  In situations where it is known that the script will never be
executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR.
 \fBTcl_Eval\fR returns a completion code and result just like 
\fBTcl_EvalObjEx\fR.  Note: for backward compatibility with versions before
Tcl 8.0, \fBTcl_Eval\fR copies the object result in \fIinterp\fR to







|







113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
\fIobjv\fR.  \fBTcl_EvalObjv\fR evaluates the command and returns
a completion code and result just like \fBTcl_EvalObjEx\fR.
.PP
\fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to
be executed is supplied as a string instead of an object and no compilation
occurs.  The string should be a proper UTF-8 string as converted by
\fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known
to possibly contain upper ASCII characters who's possible combinations
might be a UTF-8 special code.  The string is parsed and executed directly
(using \fBTcl_EvalObjv\fR) instead of compiling it and executing the
bytecodes.  In situations where it is known that the script will never be
executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR.
 \fBTcl_Eval\fR returns a completion code and result just like 
\fBTcl_EvalObjEx\fR.  Note: for backward compatibility with versions before
Tcl 8.0, \fBTcl_Eval\fR copies the object result in \fIinterp\fR to
Changes to doc/ExprLong.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ExprLong.3,v 1.4.12.1 2002/02/05 02:21:57 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ExprLong.3,v 1.4.12.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression
.SH SYNOPSIS
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
.SH ARGUMENTS
.AS Tcl_Interp *booleanPtr
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
.VS 8.4
.AP "CONST char" *string in
.VE
Expression to be evaluated.  Must be in writable memory (the expression
parser makes temporary modifications to the string during parsing, which
it undoes before returning).
.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







|
<
<







30
31
32
33
34
35
36
37


38
39
40
41
42
43
44
.SH ARGUMENTS
.AS Tcl_Interp *booleanPtr
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
.VS 8.4
.AP "CONST char" *string in
.VE
Expression to be evaluated.  


.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
.AP int *doublePtr out
Pointer to location in which to store the floating-point value of the
expression.
.AP int *booleanPtr out
Changes to doc/FileSystem.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2001 Vincent Darley
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: FileSystem.3,v 1.8.2.2 2002/06/10 05:33:08 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2001 Vincent Darley
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: FileSystem.3,v 1.8.2.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Filesystem 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem
.SH SYNOPSIS
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Tcl_Obj*
\fBTcl_FSListVolumes\fR(\fIvoid\fR)
.sp
int
\fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR)
.sp
int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr\fR)
.sp
int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR)
.sp
Tcl_Obj*
\fBTcl_FSLink\fR(\fIpathPtr, toPtr\fR)
.sp
int
\fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR)
.sp
int
\fBTcl_FSUtime\fR(\fIpathPtr, tval\fR)
.sp







|





|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Tcl_Obj*
\fBTcl_FSListVolumes\fR(\fIvoid\fR)
.sp
int
\fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR)
.sp
int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, handlePtr, unloadProcPtr\fR)
.sp
int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR)
.sp
Tcl_Obj*
\fBTcl_FSLink\fR(\fIlinkNamePtr, toPtr, linkAction\fR)
.sp
int
\fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR)
.sp
int
\fBTcl_FSUtime\fR(\fIpathPtr, tval\fR)
.sp
253
254
255
256
257
258
259
260
261
262

263
264
265
266



267
268
269
270


271
272
273
274
275
276
277
a lookup table of functions to implement all or some of the functionality
listed here.  Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls
abstract away from what the 'struct stat' buffer buffer is actually
declared to be, allowing the same code to be used both on systems with
and systems without support for files larger than 2GB in size.
.PP
The \fBTcl_FS...\fR are objectified and may cache internal
representations and other path-related strings (e.g. the current
working directory).  One side-effect of this is that one must be
careful when passing in temporary objects with a refCount of zero. 

Under some circumstances, the filesystem code may wish to retain a
reference to the passed in object, and so one must not assume that
after any of these calls return, the object still has a refCount of
zero - it may have been incremented.  The practical lesson to learn



from this is that \fBTcl_Obj *path = Tcl_NewStringObj(...) ;
Tcl_FS...(path) ; Tcl_DecrRefCount(path)\fR is wrong, and may
segfault.  The 'path' must have its refCount incremented before
passing it in, or decrementing it.


.PP
\fBTcl_FSCopyFile\fR attempts to copy the file given by srcPathPtr to the
path name given by destPathPtr.  If the two paths given lie in the same
filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that
filesystem's 'copy file' function is called (if it is non-NULL).
Otherwise the function returns -1 and sets Tcl's errno to the 'EXDEV'
posix error code (which signifies a 'cross-domain link').







|
|
|
>
|
|
|
|
>
>
>
|
|
|
|
>
>







253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
a lookup table of functions to implement all or some of the functionality
listed here.  Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls
abstract away from what the 'struct stat' buffer buffer is actually
declared to be, allowing the same code to be used both on systems with
and systems without support for files larger than 2GB in size.
.PP
The \fBTcl_FS...\fR are objectified and may cache internal
representations and other path-related strings (e.g. the current working
directory).  One side-effect of this is that one must not pass in objects
with a refCount of zero to any of these functions.  If such calls were 
handled, they might result
in memory leaks (under some circumstances, the filesystem code may wish
to retain a reference to the passed in object, and so one must not assume
that after any of these calls return, the object still has a refCount of
zero - it may have been incremented), or in a direct segfault
due to the object being freed part way through the complex object
manipulation required to ensure that the path is fully normalized and
absolute for filesystem determination.  The practical lesson to learn
from this is that \fBTcl_Obj *path = Tcl_NewStringObj(...)  ;
Tcl_FS...(path) ; Tcl_DecrRefCount(path)\fR is wrong, and may segfault.
The 'path' must have its refCount incremented before passing it in, or
decrementing it.  For this reason, objects with a refCount of zero are
considered not to be valid filesystem paths and calling any Tcl_FS API
with such an object will result in no action being taken.
.PP
\fBTcl_FSCopyFile\fR attempts to copy the file given by srcPathPtr to the
path name given by destPathPtr.  If the two paths given lie in the same
filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that
filesystem's 'copy file' function is called (if it is non-NULL).
Otherwise the function returns -1 and sets Tcl's errno to the 'EXDEV'
posix error code (which signifies a 'cross-domain link').
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355



356


357
358
359
360
361
362
363
364
 	
Note that the 'glob' code implements recursive patterns internally, so
this function will only ever be passed simple patterns, which can be
matched using the logic of 'string match'.  To handle recursion, Tcl
will call this function frequently asking only for directories to be
returned.
.PP
\fBTcl_FSLink\fR replaces the library version of readlink(), and may
also be used in the future to allow link creation.
The appropriate function for the filesystem to which pathPtr
belongs will be called.
.PP
If the \fItoPtr\fR is NULL, a readlink action is performed.
The result is a Tcl_Obj specifying the contents of the symbolic link
given by \fIpath\fR, 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 the \fItoPtr\fR is not NULL, Tcl



should create a link, but this option is not currently supported (it


is left available for future expansion).
.PP
\fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file.  You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file.  The stat structure
includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on







|
<
|
|

|
|
|
|
|
>
>
>
|
>
>
|







345
346
347
348
349
350
351
352

353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
 	
Note that the 'glob' code implements recursive patterns internally, so
this function will only ever be passed simple patterns, which can be
matched using the logic of 'string match'.  To handle recursion, Tcl
will call this function frequently asking only for directories to be
returned.
.PP
\fBTcl_FSLink\fR replaces the library version of readlink(), and

extends it to support the creation of links.  The appropriate function 
for the filesystem to which linkNamePtr belongs will be called.
.PP
If the \fItoPtr\fR is NULL, a readlink action is performed.  The result
is a Tcl_Obj specifying the contents of the symbolic link given by
\fIlinkNamePtr\fR, or NULL if the link could not be read.  The result is owned
by the caller, which should call Tcl_DecrRefCount when the result is no
longer needed.  If the \fItoPtr\fR is not NULL, Tcl should create a link
of one of the types passed in in the \fIlinkAction\fR flag.  This flag is
an or'd combination of TCL_CREATE_SYMBOLIC_LINK and TCL_CREATE_HARD_LINK.
Where a choice exists (i.e. more than one flag is passed in), the Tcl
convention is to prefer symbolic links.  When a link is successfully
created, the return value should be \fItoPtr\fR (which is therefore
already owned by the caller).  If unsuccessful, NULL should be
returned.
.PP
\fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information
about the specified file.  You do not need any access rights to the
file to get this information but you need search rights to all
directories named in the path leading to the file.  The stat structure
includes info regarding device, inode (always 0 on Windows),
privilege mode, nlink (always 1 on Windows), user id (always 0 on
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
.PP
\fBTcl_FSOpenFileChannel\fR opens a file specified by \fIpathPtr\fR and
returns a channel handle that can be used to perform input and output on
the file. This API is modeled after the \fBfopen\fR procedure of
the Unix standard I/O library.
The syntax and meaning of all arguments is similar to those
given in the Tcl \fBopen\fR command when opening a file.
If an error occurs while opening the channel, \fBTcl_OpenFileChannel\fR
returns NULL and records a POSIX error code that can be
retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR
leaves an error message in \fIinterp\fR's result after any error.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR, described below.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.







|


|







434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
.PP
\fBTcl_FSOpenFileChannel\fR opens a file specified by \fIpathPtr\fR and
returns a channel handle that can be used to perform input and output on
the file. This API is modeled after the \fBfopen\fR procedure of
the Unix standard I/O library.
The syntax and meaning of all arguments is similar to those
given in the Tcl \fBopen\fR command when opening a file.
If an error occurs while opening the channel, \fBTcl_FSOpenFileChannel\fR
returns NULL and records a POSIX error code that can be
retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, \fBTcl_FSOpenFileChannel\fR
leaves an error message in \fIinterp\fR's result after any error.
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR, described below.
If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it as a
replacement for the standard channel.
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960

961
962
963
964
965
966
967
968
969
970
971
972
973
which require open or accessing a file's contents will use it 
(e.g. \fBopen\fR, \fBencoding\fR, and many Tk commands).
.PP
.CS
typedef Tcl_Channel Tcl_FSOpenFileChannelProc(
	Tcl_Interp *\fIinterp\fR,
	Tcl_Obj *\fIpathPtr\fR,
	CONST char *\fImodeString\fR,
	int \fIpermissions\fR);
.CE
.PP
The \fBTcl_FSOpenFileChannelProc\fR opens a file specified by
\fIpathPtr\fR and returns a channel handle that can be used to perform
input and output on the file.  This API is modeled after the
\fBfopen\fR procedure of the Unix standard I/O library.  The syntax and
meaning of all arguments is similar to those given in the Tcl

\fBopen\fR command when opening a file.  If an error occurs while
opening the channel, the \fBTcl_FSOpenFileChannelProc\fR returns NULL
and records a POSIX error code that can be retrieved with
\fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, the
\fBTcl_FSOpenFileChannelProc\fR leaves an error message in
\fIinterp\fR's result after any error.
.PP
The newly created channel is not registered in the supplied
interpreter; to register it, use \fBTcl_RegisterChannel\fR. If one of
the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it
as a replacement for the standard channel.
.SH MATCHINDIRECTORYPROC  







|





|
|
|
>
|
|
|
|
|
|







955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
which require open or accessing a file's contents will use it 
(e.g. \fBopen\fR, \fBencoding\fR, and many Tk commands).
.PP
.CS
typedef Tcl_Channel Tcl_FSOpenFileChannelProc(
	Tcl_Interp *\fIinterp\fR,
	Tcl_Obj *\fIpathPtr\fR,
	int \fImode\fR,
	int \fIpermissions\fR);
.CE
.PP
The \fBTcl_FSOpenFileChannelProc\fR opens a file specified by
\fIpathPtr\fR and returns a channel handle that can be used to perform
input and output on the file.  This API is modeled after the \fBfopen\fR
procedure of the Unix standard I/O library.  The syntax and meaning of
all arguments is similar to those given in the Tcl \fBopen\fR command
when opening a file, where the \fImode\fR argument is a combination of
the POSIX flags O_RDONLY, O_WRONLY, etc.  If an error occurs while
opening the channel, the \fBTcl_FSOpenFileChannelProc\fR returns NULL and
records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, the
\fBTcl_FSOpenFileChannelProc\fR leaves an error message in \fIinterp\fR's
result after any error.
.PP
The newly created channel is not registered in the supplied
interpreter; to register it, use \fBTcl_RegisterChannel\fR. If one of
the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was
previously closed, the act of creating the new channel also assigns it
as a replacement for the standard channel.
.SH MATCHINDIRECTORYPROC  
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
occurred in the matching process.  Error messages are placed in interp, 
but on a TCL_OK result, the interpreter should not be modified, but
rather results should be added to the \fIresult\fR object given
(which can be assumed to be a valid Tcl list).  The matches added
to \fIresult\fR should include any path prefix given in \fIpathPtr\fR 
(this usually means they will be absolute path specifications). 
Note that if no matches are found, that simply leads to an empty 
result --- errors are only signalled for actual file or filesystem
problems which may occur during the matching process.
.SH UTIMEPROC       
.PP
Function to process a \fBTcl_FSUtime()\fR call.  Required to allow setting
(not reading) of times with 'file mtime', 'file atime' and the
open-r/open-w/fcopy implementation of 'file copy'.
.PP







|







1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
occurred in the matching process.  Error messages are placed in interp, 
but on a TCL_OK result, the interpreter should not be modified, but
rather results should be added to the \fIresult\fR object given
(which can be assumed to be a valid Tcl list).  The matches added
to \fIresult\fR should include any path prefix given in \fIpathPtr\fR 
(this usually means they will be absolute path specifications). 
Note that if no matches are found, that simply leads to an empty 
result --- errors are only signaled for actual file or filesystem
problems which may occur during the matching process.
.SH UTIMEPROC       
.PP
Function to process a \fBTcl_FSUtime()\fR call.  Required to allow setting
(not reading) of times with 'file mtime', 'file atime' and the
open-r/open-w/fcopy implementation of 'file copy'.
.PP
1026
1027
1028
1029
1030
1031
1032
1033
1034

1035
1036
1037
1038
1039
1040
1041
1042
1043
1044


1045
1046
1047
1048
1049
1050
1051
.SH LINKPROC 
.PP
Function to process a \fBTcl_FSLink()\fR call.  Should be implemented
only if the filesystem supports links, and may otherwise be NULL.
.PP
.CS
typedef Tcl_Obj* Tcl_FSLinkProc(
	Tcl_Obj *\fIpathPtr\fR,
	Tcl_Obj *\fItoPtr\fR);

.CE
.PP
If \fItoPtr\fR is NULL, the function is being asked to read the
contents of a link.  The result is a Tcl_Obj specifying the contents of
the symbolic link given by 'path', 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 \fItoPtr\fR 
is not NULL, the function should attempt to create a link.  The result
in this case should be \fItoPtr\fR if the link was successful and NULL
otherwise.  In this case the result is not owned by the caller.


.SH LISTVOLUMESPROC	    
.PP
Function to list any filesystem volumes added by this filesystem.
Should be implemented only if the filesystem adds volumes at the head
of the filesystem, so that they can be returned by 'file volumes'.
.PP
.CS







|
|
>




|




|
>
>







1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
.SH LINKPROC 
.PP
Function to process a \fBTcl_FSLink()\fR call.  Should be implemented
only if the filesystem supports links, and may otherwise be NULL.
.PP
.CS
typedef Tcl_Obj* Tcl_FSLinkProc(
	Tcl_Obj *\fIlinkNamePtr\fR,
	Tcl_Obj *\fItoPtr\fR,
	int \fIlinkAction\fR);
.CE
.PP
If \fItoPtr\fR is NULL, the function is being asked to read the
contents of a link.  The result is a Tcl_Obj specifying the contents of
the link given by \fIlinkNamePtr\fR, or NULL if the link could
not be read.  The result is owned by the caller, which should call
Tcl_DecrRefCount when the result is no longer needed.  If \fItoPtr\fR 
is not NULL, the function should attempt to create a link.  The result
in this case should be \fItoPtr\fR if the link was successful and NULL
otherwise.  In this case the result is not owned by the caller. See
the documentation for \fBTcl_FSLink\fR for the correct interpretation
of the \fIlinkAction\fR flags.
.SH LISTVOLUMESPROC	    
.PP
Function to list any filesystem volumes added by this filesystem.
Should be implemented only if the filesystem adds volumes at the head
of the filesystem, so that they can be returned by 'file volumes'.
.PP
.CS
1164
1165
1166
1167
1168
1169
1170
1171



1172
1173
1174
1175
1176
1177
1178
.CS
typedef int Tcl_FSDeleteFileProc(
	Tcl_Obj *\fIpathPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the process.  If successful, the file specified by
\fIpathPtr\fR should have been removed from the filesystem.



.SH "FILESYSTEM EFFICIENCY"
.PP
.SH LSTATPROC	    
.PP
Function to process a \fBTcl_FSLstat()\fR call.  If not implemented, Tcl
will attempt to use the \fIstatProc\fR defined above instead.  Therefore
it need only be implemented if a filesystem can differentiate between







|
>
>
>







1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
.CS
typedef int Tcl_FSDeleteFileProc(
	Tcl_Obj *\fIpathPtr\fR);
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the process.  If successful, the file specified by
\fIpathPtr\fR should have been removed from the filesystem.  Note that,
if the filesystem supports symbolic links, Tcl will always call this
function and not Tcl_FSRemoveDirectoryProc when needed to delete them
(even if they are symbolic links to directories).
.SH "FILESYSTEM EFFICIENCY"
.PP
.SH LSTATPROC	    
.PP
Function to process a \fBTcl_FSLstat()\fR call.  If not implemented, Tcl
will attempt to use the \fIstatProc\fR defined above instead.  Therefore
it need only be implemented if a filesystem can differentiate between
1203
1204
1205
1206
1207
1208
1209
1210



1211
1212
1213
1214
1215
1216
1217
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the copying process.  Note that, \fIdestPathPtr\fR is the
name of the file which should become the copy of \fIsrcPathPtr\fR. It
is never the name of a directory into which \fIsrcPathPtr\fR could be
copied (i.e. the function is much simpler than the Tcl level 'file
copy' subcommand).



.SH RENAMEFILEPROC	    
.PP
Function to process a \fBTcl_FSRenameFile()\fR call.  If not implemented,
Tcl will fall back on a copy and delete mechanism.  Therefore it need
only be implemented if the filesystem can perform that action more
efficiently.
.PP







|
>
>
>







1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
.CE
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the copying process.  Note that, \fIdestPathPtr\fR is the
name of the file which should become the copy of \fIsrcPathPtr\fR. It
is never the name of a directory into which \fIsrcPathPtr\fR could be
copied (i.e. the function is much simpler than the Tcl level 'file
copy' subcommand).  Note that,
if the filesystem supports symbolic links, Tcl will always call this
function and not Tcl_FSCopyDirectoryProc when needed to copy them
(even if they are symbolic links to directories).
.SH RENAMEFILEPROC	    
.PP
Function to process a \fBTcl_FSRenameFile()\fR call.  If not implemented,
Tcl will fall back on a copy and delete mechanism.  Therefore it need
only be implemented if the filesystem can perform that action more
efficiently.
.PP
1254
1255
1256
1257
1258
1259
1260
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
return TCL_ERROR to disable load functionality in this filesystem
entirely.
.PP
.CS
typedef int Tcl_FSLoadFileProc(
	Tcl_Interp * \fIinterp\fR, 
	Tcl_Obj *\fIpathPtr\fR, 
	CONST char * \fIsym1\fR, 
	CONST char * \fIsym2\fR, 
	Tcl_PackageInitProc ** \fIproc1Ptr\fR, 
	Tcl_PackageInitProc ** \fIproc2Ptr\fR, 
	ClientData * \fIclientDataPtr\fR,
	Tcl_FSUnloadFileProc * \fIunloadProcPtr\fR);
.CE
.PP
Returns a standard Tcl completion code.  If an error occurs, an error
message is left in the interp's result.  The function dynamically loads
a binary code file into memory and returns the addresses of two
procedures within that file, if they are defined.  On a successful
load, the \fIclientDataPtr\fR should be filled with a token for 
the dynamically loaded file, and the \fIunloadProcPtr\fR should be
filled in with the address of a procedure.  The procedure will be
called with the given clientData as its only parameter when Tcl 
needs to unload the file.
.SH UNLOADFILEPROC	    
.PP
Function to unload a previously successfully loaded file.  If load was
implemented, then this should also be implemented, if there is any
cleanup action required.
.PP
.CS
typedef void Tcl_FSUnloadFileProc(
	ClientData \fIclientData\fR);
.CE
.SH GETCWDPROC     
.PP
Function to process a \fBTcl_FSGetCwd()\fR call.  Most filesystems need not
implement this.  It will usually only be called once, if 'getcwd' is
called before 'chdir'.  May be NULL.
.PP







|
<
<
<
<





|
<
|


|









|







1274
1275
1276
1277
1278
1279
1280
1281




1282
1283
1284
1285
1286
1287

1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
return TCL_ERROR to disable load functionality in this filesystem
entirely.
.PP
.CS
typedef int Tcl_FSLoadFileProc(
	Tcl_Interp * \fIinterp\fR, 
	Tcl_Obj *\fIpathPtr\fR, 
	Tcl_LoadHandle * \fIhandlePtr\fR,




	Tcl_FSUnloadFileProc * \fIunloadProcPtr\fR);
.CE
.PP
Returns a standard Tcl completion code.  If an error occurs, an error
message is left in the interp's result.  The function dynamically loads
a binary code file into memory.  On a successful

load, the \fIhandlePtr\fR should be filled with a token for 
the dynamically loaded file, and the \fIunloadProcPtr\fR should be
filled in with the address of a procedure.  The procedure will be
called with the given Tcl_LoadHandle as its only parameter when Tcl 
needs to unload the file.
.SH UNLOADFILEPROC	    
.PP
Function to unload a previously successfully loaded file.  If load was
implemented, then this should also be implemented, if there is any
cleanup action required.
.PP
.CS
typedef void Tcl_FSUnloadFileProc(
	Tcl_LoadHandle \fIloadHandle\fR);
.CE
.SH GETCWDPROC     
.PP
Function to process a \fBTcl_FSGetCwd()\fR call.  Most filesystems need not
implement this.  It will usually only be called once, if 'getcwd' is
called before 'chdir'.  May be NULL.
.PP
Changes to doc/Hash.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Hash.3,v 1.8.14.1 2002/02/05 02:21:57 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Hash.3,v 1.8.14.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables
.SH SYNOPSIS
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
previous call to \fBTcl_InitHashTable\fR).
.AP int keyType in
Kind of keys to use for new hash table.  Must be either
TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, TCL_CUSTOM_TYPE_KEYS,
TCL_CUSTOM_PTR_KEYS, or an integer value greater than 1.
.AP Tcl_HashKeyType *typePtr in
Address of structure which defines the behaviour of the hash table.
.AP char *key in
Key to use for probe into table.  Exact form depends on
\fIkeyType\fR used to create table.
.AP int *newPtr out
The word at \fI*newPtr\fR is set to 1 if a new entry was created
and 0 if there was already an entry for \fIkey\fR.
.AP Tcl_HashEntry *entryPtr in
Pointer to hash table entry.







|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
previous call to \fBTcl_InitHashTable\fR).
.AP int keyType in
Kind of keys to use for new hash table.  Must be either
TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, TCL_CUSTOM_TYPE_KEYS,
TCL_CUSTOM_PTR_KEYS, or an integer value greater than 1.
.AP Tcl_HashKeyType *typePtr in
Address of structure which defines the behaviour of the hash table.
.AP "CONST char" *key in
Key to use for probe into table.  Exact form depends on
\fIkeyType\fR used to create table.
.AP int *newPtr out
The word at \fI*newPtr\fR is set to 1 if a new entry was created
and 0 if there was already an entry for \fIkey\fR.
.AP Tcl_HashEntry *entryPtr in
Pointer to hash table entry.
Changes to doc/InitStubs.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: InitStubs.3,v 1.6.4.1 2002/02/05 02:21:57 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_InitStubs \- initialize the Tcl stubs mechanism
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: InitStubs.3,v 1.6.4.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_InitStubs \- initialize the Tcl stubs mechanism
.SH SYNOPSIS
82
83
84
85
86
87
88
89
90
91
extension is indicating that newer versions of Tcl are acceptable
as long as they have the same major version number as \fIversion\fR;
non-zero means that only the specified \fIversion\fR is acceptable.
\fBTcl_InitStubs\fR returns a string containing the actual version
of Tcl satisfying the request, or NULL if the Tcl version is not
acceptable, does not support stubs, or any other error condition occurred.
.SH "SEE ALSO"
\fBTk_InitStubs\fR
.SH KEYWORDS
stubs







|


82
83
84
85
86
87
88
89
90
91
extension is indicating that newer versions of Tcl are acceptable
as long as they have the same major version number as \fIversion\fR;
non-zero means that only the specified \fIversion\fR is acceptable.
\fBTcl_InitStubs\fR returns a string containing the actual version
of Tcl satisfying the request, or NULL if the Tcl version is not
acceptable, does not support stubs, or any other error condition occurred.
.SH "SEE ALSO"
Tk_InitStubs
.SH KEYWORDS
stubs
Changes to doc/LinkVar.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: LinkVar.3,v 1.3.18.1 2002/06/10 05:33:08 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: LinkVar.3,v 1.3.18.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable
.SH SYNOPSIS
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
.sp
\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR)
.SH ARGUMENTS
.AS Tcl_Interp writable
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
.AP char *varName in
Name of global variable.  Must be in writable memory: Tcl may make
temporary modifications to it while parsing the variable name.
.AP char *addr in
Address of C variable that is to be linked to \fIvarName\fR.
.AP int type in
Type of C variable.  Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE,
.VS 8.4
TCL_LINK_WIDE_INT,
.VE 8.4







|
|
<







23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
.sp
\fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR)
.SH ARGUMENTS
.AS Tcl_Interp writable
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
.AP "CONST char" *varName in
Name of global variable.  

.AP char *addr in
Address of C variable that is to be linked to \fIvarName\fR.
.AP int type in
Type of C variable.  Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE,
.VS 8.4
TCL_LINK_WIDE_INT,
.VE 8.4
Changes to doc/Notifier.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Notifier.3,v 1.8 2000/07/24 00:03:02 jenglish 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Notifier.3,v 1.8.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Notifier 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces
.SH SYNOPSIS
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
.AP Tcl_EventDeleteProc *deleteProc in
Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR.
.AP int flags in
What types of events to service.  These flags are the same as those
passed to \fBTcl_DoOneEvent\fR.
.VS 8.1
.AP int mode in
Inidicates whether events should be serviced by \fBTcl_ServiceAll\fR.
Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR.
.VE
.BE

.SH INTRODUCTION
.PP
The interfaces described here are used to customize the Tcl event







|







97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
.AP Tcl_EventDeleteProc *deleteProc in
Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR.
.AP int flags in
What types of events to service.  These flags are the same as those
passed to \fBTcl_DoOneEvent\fR.
.VS 8.1
.AP int mode in
Indicates whether events should be serviced by \fBTcl_ServiceAll\fR.
Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR.
.VE
.BE

.SH INTRODUCTION
.PP
The interfaces described here are used to customize the Tcl event
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
\fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR.  To
support a new platform or to integrate Tcl with an
application-specific event loop, you must write new versions of these
procedures.
.PP
\fBTcl_InitNotifier\fR initializes the notifier state and returns
a handle to the notifier state.  Tcl calls this
procedure when intializing a Tcl interpreter.  Similarly,
\fBTcl_FinalizeNotifier\fR shuts down the notifier, and is
called by \fBTcl_Finalize\fR when shutting down a Tcl interpreter.
.PP
\fBTcl_WaitForEvent\fR is the lowest-level procedure in the notifier;
it is responsible for waiting for an ``interesting'' event to occur or
for a given time to elapse.  Before \fBTcl_WaitForEvent\fR is invoked,
each of the event sources' setup procedure will have been invoked.







|







462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
\fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR.  To
support a new platform or to integrate Tcl with an
application-specific event loop, you must write new versions of these
procedures.
.PP
\fBTcl_InitNotifier\fR initializes the notifier state and returns
a handle to the notifier state.  Tcl calls this
procedure when initializing a Tcl interpreter.  Similarly,
\fBTcl_FinalizeNotifier\fR shuts down the notifier, and is
called by \fBTcl_Finalize\fR when shutting down a Tcl interpreter.
.PP
\fBTcl_WaitForEvent\fR is the lowest-level procedure in the notifier;
it is responsible for waiting for an ``interesting'' event to occur or
for a given time to elapse.  Before \fBTcl_WaitForEvent\fR is invoked,
each of the event sources' setup procedure will have been invoked.
Changes to doc/ObjectType.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ObjectType.3,v 1.3.14.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType  \- manipulate Tcl object types
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ObjectType.3,v 1.3.14.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType  \- manipulate Tcl object types
.SH SYNOPSIS
130
131
132
133
134
135
136


137
138
139
140
141
142
143
gets an up-to-date string representation for \fIobjPtr\fR
by calling \fBTcl_GetStringFromObj\fR.
It parses the string to obtain an integer and,
if this succeeds,
stores the integer in \fIobjPtr\fR's internal representation
and sets \fIobjPtr\fR's \fItypePtr\fR member to point to the integer type's
Tcl_ObjType structure.


.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
from an object's internal representation.
.CS
typedef void (Tcl_UpdateStringProc) (Tcl_Obj *\fIobjPtr\fR);
.CE







>
>







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
gets an up-to-date string representation for \fIobjPtr\fR
by calling \fBTcl_GetStringFromObj\fR.
It parses the string to obtain an integer and,
if this succeeds,
stores the integer in \fIobjPtr\fR's internal representation
and sets \fIobjPtr\fR's \fItypePtr\fR member to point to the integer type's
Tcl_ObjType structure.
Do not release \fIobjPtr\fR's old internal representation unless you
replace it with a new one or reset the \fItypePtr\fR member to NULL.
.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
from an object's internal representation.
.CS
typedef void (Tcl_UpdateStringProc) (Tcl_Obj *\fIobjPtr\fR);
.CE
Changes to doc/OpenFileChnl.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.13.4.1 2002/02/05 02:21:57 wolfsuit Exp $
.so man.macros
.TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: OpenFileChnl.3,v 1.13.4.2 2002/08/20 20:25:24 das Exp $
.so man.macros
.TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels
.SH SYNOPSIS
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
open for reading and writing.
.PP
\fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the
names of the registered channels to the interpreter's result as a
list object.  \fBTcl_GetChannelNamesEx\fR will filter these names
according to the \fIpattern\fR.  If \fIpattern\fR is NULL, then it
will not do any filtering.  The return value is \fBTCL_OK\fR if no
errors occured writing to the result, otherwise it is \fBTCL_ERROR\fR,
and the error message is left in the interpreter's result.

.SH TCL_REGISTERCHANNEL
.PP
\fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible
in \fIinterp\fR. After this call, Tcl programs executing in that
interpreter can refer to the channel in input or output operations using







|







321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
open for reading and writing.
.PP
\fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the
names of the registered channels to the interpreter's result as a
list object.  \fBTcl_GetChannelNamesEx\fR will filter these names
according to the \fIpattern\fR.  If \fIpattern\fR is NULL, then it
will not do any filtering.  The return value is \fBTCL_OK\fR if no
errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR,
and the error message is left in the interpreter's result.

.SH TCL_REGISTERCHANNEL
.PP
\fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible
in \fIinterp\fR. After this call, Tcl programs executing in that
interpreter can refer to the channel in input or output operations using
668
669
670
671
672
673
674
675
676
677
678
679
the channel was created with \fBTcl_OpenFileChannel\fR,
\fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR.  Other
channel types may return a different type of handle on Windows
platforms.  On the Macintosh platform, the handle is a file reference
number as returned from \fBHOpenDF\fR.

.SH "SEE ALSO"
DString(3), fconfigure(n), filename(n), fopen(2), Tcl_CreateChannel(3)

.SH KEYWORDS
access point, blocking, buffered I/O, channel, channel driver, end of file,
flush, input, nonblocking, output, read, seek, write







|




668
669
670
671
672
673
674
675
676
677
678
679
the channel was created with \fBTcl_OpenFileChannel\fR,
\fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR.  Other
channel types may return a different type of handle on Windows
platforms.  On the Macintosh platform, the handle is a file reference
number as returned from \fBHOpenDF\fR.

.SH "SEE ALSO"
DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3)

.SH KEYWORDS
access point, blocking, buffered I/O, channel, channel driver, end of file,
flush, input, nonblocking, output, read, seek, write
Changes to doc/ParseCmd.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ParseCmd.3,v 1.7.4.1 2002/02/05 02:21:57 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: ParseCmd.3,v 1.7.4.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions
.SH SYNOPSIS
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
.AP Tcl_Interp *interp out
For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR
and \fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR,
determines the context for evaluating the
script and also is used for error reporting; must not be NULL.
.AP char *string in
Pointer to first character in string to parse.
.AP int numBytes in
Number of bytes in \fIstring\fR, not including any terminating null
character.  If less than 0 then the script consists of all characters
in \fIstring\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an







|







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
.AP Tcl_Interp *interp out
For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR
and \fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR,
determines the context for evaluating the
script and also is used for error reporting; must not be NULL.
.AP "CONST char" *string in
Pointer to first character in string to parse.
.AP int numBytes in
Number of bytes in \fIstring\fR, not including any terminating null
character.  If less than 0 then the script consists of all characters
in \fIstring\fR up to the first null character.
.AP int nested in
Non-zero means that the script is part of a command substitution so an
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
.AP Tcl_Parse *parsePtr out
Points to structure to fill in with information about the parsed
command, expression, variable name, etc.
Any previous information in this structure
is ignored, unless \fIappend\fR is non-zero in a call to
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR,
or \fBTcl_ParseVarName\fR.
.AP char **termPtr out
If not NULL, points to a location where
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and
\fBTcl_ParseVar\fR will store a pointer to the character
just after the terminating character (the close-brace, the last
character of the variable name, or the close-quote (respectively))
if the parse was successful.
.AP Tcl_Parse *usedParsePtr in







|







67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
.AP Tcl_Parse *parsePtr out
Points to structure to fill in with information about the parsed
command, expression, variable name, etc.
Any previous information in this structure
is ignored, unless \fIappend\fR is non-zero in a call to
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR,
or \fBTcl_ParseVarName\fR.
.AP "CONST char" **termPtr out
If not NULL, points to a location where
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and
\fBTcl_ParseVar\fR will store a pointer to the character
just after the terminating character (the close-brace, the last
character of the variable name, or the close-quote (respectively))
if the parse was successful.
.AP Tcl_Parse *usedParsePtr in
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
If the braced string was parsed successfully,
\fBTcl_ParseBraces\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB}\fR
in the location given by \fI*termPtr\fR.
If an error occurrs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseQuotedString\fR parses a double-quoted string such as
\fB"sum is [expr $a+$b]"\fR
from the beginning of the argument \fIstring\fR.
The first character of \fIstring\fR must be \fB"\fR. 
If the double-quoted string was parsed successfully,
\fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB"\fR
in the location given by \fI*termPtr\fR.
If an error occurrs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseVarName\fR parses a Tcl variable reference such as
\fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its
\fIstring\fR argument.
The first character of \fIstring\fR must be \fB$\fR. 
If a variable name was parsed successfully, \fBTcl_ParseVarName\fR
returns \fBTCL_OK\fR and fills in the structure pointed to by
\fIparsePtr\fR with information about the structure of the variable name
(see below for details).  If an error
occurrs while parsing the command then \fBTCL_ERROR\fR is returned, an
error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't
NULL), and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR
or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR
argument.  The first character of \fIstring\fR must be \fB$\fR.  If
the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a







|















|












|







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
If the braced string was parsed successfully,
\fBTcl_ParseBraces\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB}\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseQuotedString\fR parses a double-quoted string such as
\fB"sum is [expr $a+$b]"\fR
from the beginning of the argument \fIstring\fR.
The first character of \fIstring\fR must be \fB"\fR. 
If the double-quoted string was parsed successfully,
\fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR,
fills in the structure pointed to by \fIparsePtr\fR
with information about the structure of the string
(see below for details),
and stores a pointer to the character just after the terminating \fB"\fR
in the location given by \fI*termPtr\fR.
If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
.PP
\fBTcl_ParseVarName\fR parses a Tcl variable reference such as
\fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its
\fIstring\fR argument.
The first character of \fIstring\fR must be \fB$\fR. 
If a variable name was parsed successfully, \fBTcl_ParseVarName\fR
returns \fBTCL_OK\fR and fills in the structure pointed to by
\fIparsePtr\fR with information about the structure of the variable name
(see below for details).  If an error
occurs while parsing the command then \fBTCL_ERROR\fR is returned, an
error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't
NULL), and no information is left at \fI*parsePtr\fR.
.PP
\fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR
or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR
argument.  The first character of \fIstring\fR must be \fB$\fR.  If
the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
The \fInumComponents\fR field
counts the total number of sub-tokens that make up the subexpression;
this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens.
.TP
\fBTCL_TOKEN_OPERATOR\fR
The token describes one operator of an expression
such as \fB&&\fR or \fBhypot\fR.
An \fBTCL_TOKEN_OPERATOR\fR token is always preceeded by a
\fBTCL_TOKEN_SUB_EXPR\fR token
that describes the operator and its operands;
the \fBTCL_TOKEN_SUB_EXPR\fR token's \fInumComponents\fR field
can be used to determine the number of operands.
A binary operator such as \fB*\fR
is followed by two \fBTCL_TOKEN_SUB_EXPR\fR tokens
that describe its operands.







|







341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
The \fInumComponents\fR field
counts the total number of sub-tokens that make up the subexpression;
this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens.
.TP
\fBTCL_TOKEN_OPERATOR\fR
The token describes one operator of an expression
such as \fB&&\fR or \fBhypot\fR.
An \fBTCL_TOKEN_OPERATOR\fR token is always preceded by a
\fBTCL_TOKEN_SUB_EXPR\fR token
that describes the operator and its operands;
the \fBTCL_TOKEN_SUB_EXPR\fR token's \fInumComponents\fR field
can be used to determine the number of operands.
A binary operator such as \fB*\fR
is followed by two \fBTCL_TOKEN_SUB_EXPR\fR tokens
that describe its operands.
Changes to doc/RegExp.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: RegExp.3,v 1.9.2.1 2002/02/05 02:21:58 wolfsuit 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








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: RegExp.3,v 1.9.2.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions
.SH SYNOPSIS
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
direct control of Henry Spencer's regular expression library.  For
users that need to modify compilation and execution options directly,
it is recommended that you use these interfaces instead of calling the
internal regexp functions.  These interfaces handle the details of UTF
to Unicode translations as well as providing improved performance
through caching in the pattern and string objects.
.PP
\fBTcl_GetRegExpFromObj\fR attepts to return a compiled regular
expression from the \fIpatObj\fR.  If the object does not already
contain a compiled regular expression it will attempt to create one
from the string in the object and assign it to the internal
representation of the \fIpatObj\fR.  The return value of this function
is of type \fBTcl_RegExp\fR.  The return value is a token for this
compiled form, which can be used in subsequent calls to
\fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR.  If an error







|







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
direct control of Henry Spencer's regular expression library.  For
users that need to modify compilation and execution options directly,
it is recommended that you use these interfaces instead of calling the
internal regexp functions.  These interfaces handle the details of UTF
to Unicode translations as well as providing improved performance
through caching in the pattern and string objects.
.PP
\fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular
expression from the \fIpatObj\fR.  If the object does not already
contain a compiled regular expression it will attempt to create one
from the string in the object and assign it to the internal
representation of the \fIpatObj\fR.  The return value of this function
is of type \fBTcl_RegExp\fR.  The return value is a token for this
compiled form, which can be used in subsequent calls to
\fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR.  If an error
Changes to doc/SetVar.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetVar.3,v 1.3.28.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: SetVar.3,v 1.3.28.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables
.SH SYNOPSIS
49
50
51
52
53
54
55
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
.sp
int
\fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *newValuePtr
.AP Tcl_Interp *interp in
Interpreter containing variable.
.AP char *name1 in
Contains the name of an array variable (if \fIname2\fR is non-NULL)
or (if \fIname2\fR is NULL) either the name of a scalar variable
or a complete name including both variable name and index.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
.AP "CONST char" *name2 in
If non-NULL, gives name of element within array; in this
case \fIname1\fR must refer to an array variable.
.AP Tcl_Obj *newValuePtr in
.VS 8.1
Points to a Tcl object containing the new value for the variable.
.VE
.AP int flags in
OR-ed combination of bits providing additional information. See below
for valid values.
.AP char *varName in
Name of variable.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
May refer to a scalar variable or an element of
an array.
If the name references an element of an array, then the name
must be in writable memory:  Tcl will make temporary modifications 
to it while looking up the name.
.AP "CONST char" *newValue in
New value for variable, specified as a NULL-terminated string.
A copy of this value is stored in the variable.
.AP Tcl_Obj *part1Ptr in
Points to a Tcl object containing the variable's name.
The name may include a series of \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.







|















|





<
<
<







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77



78
79
80
81
82
83
84
.sp
int
\fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *newValuePtr
.AP Tcl_Interp *interp in
Interpreter containing variable.
.AP "CONST char" *name1 in
Contains the name of an array variable (if \fIname2\fR is non-NULL)
or (if \fIname2\fR is NULL) either the name of a scalar variable
or a complete name including both variable name and index.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
.AP "CONST char" *name2 in
If non-NULL, gives name of element within array; in this
case \fIname1\fR must refer to an array variable.
.AP Tcl_Obj *newValuePtr in
.VS 8.1
Points to a Tcl object containing the new value for the variable.
.VE
.AP int flags in
OR-ed combination of bits providing additional information. See below
for valid values.
.AP "CONST char" *varName in
Name of variable.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
May refer to a scalar variable or an element of
an array.



.AP "CONST char" *newValue in
New value for variable, specified as a NULL-terminated string.
A copy of this value is stored in the variable.
.AP Tcl_Obj *part1Ptr in
Points to a Tcl object containing the variable's name.
The name may include a series of \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
Changes to doc/StringObj.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.9.8.2 2002/06/10 05:33:08 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: StringObj.3,v 1.9.8.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
150
151
152
153
154
155
156
157











158
159
160
161
162
163
164
165
\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's
string representation.  This is given by the returned byte pointer and
(for \fBTcl_GetStringFromObj\fR) length, which is stored in
\fIlengthPtr\fR if it is non-NULL.  If the object's UTF string
representation is invalid (its byte pointer is NULL), the string
representation is regenerated from the object's internal
representation.  The storage referenced by the returned byte pointer
is owned by the object manager and should not be modified by the











caller.  The procedure \fBTcl_GetString\fR is used in the common case
where the caller does not need the length of the string
representation.
.PP
\fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return an object's
value as a Unicode string.  This is given by the returned pointer and
(for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in
\fIlengthPtr\fR if it is non-NULL.  The storage referenced by the returned







|
>
>
>
>
>
>
>
>
>
>
>
|







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's
string representation.  This is given by the returned byte pointer and
(for \fBTcl_GetStringFromObj\fR) length, which is stored in
\fIlengthPtr\fR if it is non-NULL.  If the object's UTF string
representation is invalid (its byte pointer is NULL), the string
representation is regenerated from the object's internal
representation.  The storage referenced by the returned byte pointer
is owned by the object manager.  It is passed back as a writable
pointer so that extension author creating their own \fBTcl_ObjType\fR
will be able to modify the string representation within the
\fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR.  Except for that
limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR
or \fBTcl_GetString\fR should be treated as read-only.  It is
recommended that this pointer be assigned to a (CONST char *) variable.
Even in the limited situations where writing to this pointer is
acceptable, one should take care to respect the copy-on-write
semantics required by \fBTcl_Obj\fR's, with appropriate calls
to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any
in-place modification of the string representation.
The procedure \fBTcl_GetString\fR is used in the common case
where the caller does not need the length of the string
representation.
.PP
\fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return an object's
value as a Unicode string.  This is given by the returned pointer and
(for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in
\fIlengthPtr\fR if it is non-NULL.  The storage referenced by the returned
Changes to doc/Tcl_Main.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Tcl_Main.3,v 1.4.6.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications
.SH SYNOPSIS








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Tcl_Main.3,v 1.4.6.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications
.SH SYNOPSIS
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more
details on this procedure, see the documentation for \fBTcl_AppInit\fR.
.PP
When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one
of its two modes.  If a startup script has been provided, \fBTcl_Main\fR
attempts to evaluate it.  Otherwise, interactive mode begins with
examination of the variable \fItcl_rcFileName\fR in the master
interperter.  If that variable exists and holds the name of a readable
file, the contents of that file are evaluated in the master interpreter.
Then interactive operations begin,
with prompts and command evaluation results written to the standard
output channel, and commands read from the standard input channel
and then evaluated.  The prompts written to the standard output
channel may be customized by defining the Tcl variables \fItcl_prompt1\fR
and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR.







|







100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more
details on this procedure, see the documentation for \fBTcl_AppInit\fR.
.PP
When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one
of its two modes.  If a startup script has been provided, \fBTcl_Main\fR
attempts to evaluate it.  Otherwise, interactive mode begins with
examination of the variable \fItcl_rcFileName\fR in the master
interpreter.  If that variable exists and holds the name of a readable
file, the contents of that file are evaluated in the master interpreter.
Then interactive operations begin,
with prompts and command evaluation results written to the standard
output channel, and commands read from the standard input channel
and then evaluated.  The prompts written to the standard output
channel may be customized by defining the Tcl variables \fItcl_prompt1\fR
and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR.
Changes to doc/Thread.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Thread.3,v 1.13 2000/07/24 00:03:03 jenglish 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1999 Scriptics Corporation
'\" Copyright (c) 1998 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Thread.3,v 1.13.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Threads 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support.
.SH SYNOPSIS
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
static and process-wide, yet each thread will end up associating
a different block of storage with this key.
.AP int *size in
The size of the thread local storage block.  This amount of data
is allocated and initialized to zero the first time each thread
calls \fBTcl_GetThreadData\fR.
.AP Tcl_ThreadId *idPtr out
The refered storage will contain the id of the newly created thread as
returned by the operating system.
.AP Tcl_ThreadId id in
Id of the thread waited upon.
.AP Tcl_ThreadCreateProc threadProc in
This procedure will act as the \fBmain()\fR of the newly created
thread. The specified \fIclientData\fR will be its sole argument.
.AP ClientData clientData in
Arbitrary information. Passed as sole argument to the \fIthreadProc\fR.
.AP int stackSize in
The size of the stack given to the new thread.
.AP int flags in
Bitmask containing flags allowing the caller to modify behaviour of
the new thread.
.AP int *result out
The refered storage is used to place the exit code of the thread
waited upon into it.
.BE
.SH INTRODUCTION
Beginning with the 8.1 release, the Tcl core is thread safe, which
allows you to incorporate Tcl into multithreaded applications without
customizing the Tcl core.  To enable Tcl multithreading support,
you must include the \fB--enable-threads\fR option to \fBconfigure\fR
when you configure and compile your Tcl core.
.PP
An important contstraint of the Tcl threads implementation is that
\fIonly the thread that created a Tcl interpreter can use that
interpreter\fR.  In other words, multiple threads can not access
the same Tcl interpreter.  (However, as was the case in previous
releases, a single thread can safely create and use multiple
interpreters.)
.PP
.VS 8.3.1
Tcl does provide \fBTcl_CreateThread\fR for creating threads. The
caller can determine the size of the stack given to the new thread and
modify the behaviour through the supplied \fIflags\fR. The value
\fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that
the default size as specified by the operating system is to be used
for the new thread. As for the flags, currently are only the values
\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The
first of them invokes the default behaviour with no
specialities. Using the second value marks the new thread as
\fIjoinable\fR. This means that another thread can wait for the such
marked thread to exit and join it.
.PP
Restrictions: On some unix systems the pthread-library does not
contain the functionality to specify the stacksize of a thread. The
specified value for the stacksize is ignored on these systems. Both
Windows and Macintosh currently do not support joinable threads. This







|














|









|















|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
static and process-wide, yet each thread will end up associating
a different block of storage with this key.
.AP int *size in
The size of the thread local storage block.  This amount of data
is allocated and initialized to zero the first time each thread
calls \fBTcl_GetThreadData\fR.
.AP Tcl_ThreadId *idPtr out
The referred storage will contain the id of the newly created thread as
returned by the operating system.
.AP Tcl_ThreadId id in
Id of the thread waited upon.
.AP Tcl_ThreadCreateProc threadProc in
This procedure will act as the \fBmain()\fR of the newly created
thread. The specified \fIclientData\fR will be its sole argument.
.AP ClientData clientData in
Arbitrary information. Passed as sole argument to the \fIthreadProc\fR.
.AP int stackSize in
The size of the stack given to the new thread.
.AP int flags in
Bitmask containing flags allowing the caller to modify behaviour of
the new thread.
.AP int *result out
The referred storage is used to place the exit code of the thread
waited upon into it.
.BE
.SH INTRODUCTION
Beginning with the 8.1 release, the Tcl core is thread safe, which
allows you to incorporate Tcl into multithreaded applications without
customizing the Tcl core.  To enable Tcl multithreading support,
you must include the \fB--enable-threads\fR option to \fBconfigure\fR
when you configure and compile your Tcl core.
.PP
An important constraint of the Tcl threads implementation is that
\fIonly the thread that created a Tcl interpreter can use that
interpreter\fR.  In other words, multiple threads can not access
the same Tcl interpreter.  (However, as was the case in previous
releases, a single thread can safely create and use multiple
interpreters.)
.PP
.VS 8.3.1
Tcl does provide \fBTcl_CreateThread\fR for creating threads. The
caller can determine the size of the stack given to the new thread and
modify the behaviour through the supplied \fIflags\fR. The value
\fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that
the default size as specified by the operating system is to be used
for the new thread. As for the flags, currently are only the values
\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The
first of them invokes the default behaviour with no
specialties. Using the second value marks the new thread as
\fIjoinable\fR. This means that another thread can wait for the such
marked thread to exit and join it.
.PP
Restrictions: On some unix systems the pthread-library does not
contain the functionality to specify the stacksize of a thread. The
specified value for the stacksize is ignored on these systems. Both
Windows and Macintosh currently do not support joinable threads. This
Changes to doc/TraceCmd.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2002 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" CVS: @(#) $Id: TraceCmd.3,v 1.4.2.1 2002/06/10 04:15:50 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 2002 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" CVS: @(#) $Id: TraceCmd.3,v 1.4.2.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command
.SH SYNOPSIS
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
\fBTcl_CommandTraceInfo\fR may be used to retrieve information about
traces set on a given command.
The return value from \fBTcl_CommandTraceInfo\fR is the \fIclientData\fR
associated with a particular trace.
The trace must be on the command specified by the \fIinterp\fR,
\fIcmdName\fR, and \fIflags\fR arguments (note that currently the
flags are ignored; \fIflags\fR should be set to 0 for future
compatability) and its trace procedure must the same as the \fIproc\fR
argument.
If the \fIprevClientData\fR argument is NULL then the return
value corresponds to the first (most recently created) matching
trace, or NULL if there are no matching traces.
If the \fIprevClientData\fR argument isn't NULL, then it should
be the return value from a previous call to \fBTcl_CommandTraceInfo\fR.
In this case, the new return value will correspond to the next
matching trace after the one whose \fIclientData\fR matches
\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR
or if there are no more matching traces after it.
This mechanism makes it possible to step through all of the
traces for a given command that have the same \fIproc\fR.

.SH "CALLING COMMANDS DURING TRACES"
.PP
During rename traces, the command being renamed is visible with both
names simultaneously, and the command still exists during delete
traces (if TCL_INTERP_DESTROYED is not set).  However, there is no
mechanism for signalling that an error occurred in a trace procedure,
so great care should be taken that errors do not get silently lost.

.SH "MULTIPLE TRACES"
.PP
It is possible for multiple traces to exist on the same command.
When this happens, all of the trace procedures will be invoked on each
access, in order from most-recently-created to least-recently-created.







|


















|







102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
\fBTcl_CommandTraceInfo\fR may be used to retrieve information about
traces set on a given command.
The return value from \fBTcl_CommandTraceInfo\fR is the \fIclientData\fR
associated with a particular trace.
The trace must be on the command specified by the \fIinterp\fR,
\fIcmdName\fR, and \fIflags\fR arguments (note that currently the
flags are ignored; \fIflags\fR should be set to 0 for future
compatibility) and its trace procedure must the same as the \fIproc\fR
argument.
If the \fIprevClientData\fR argument is NULL then the return
value corresponds to the first (most recently created) matching
trace, or NULL if there are no matching traces.
If the \fIprevClientData\fR argument isn't NULL, then it should
be the return value from a previous call to \fBTcl_CommandTraceInfo\fR.
In this case, the new return value will correspond to the next
matching trace after the one whose \fIclientData\fR matches
\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR
or if there are no more matching traces after it.
This mechanism makes it possible to step through all of the
traces for a given command that have the same \fIproc\fR.

.SH "CALLING COMMANDS DURING TRACES"
.PP
During rename traces, the command being renamed is visible with both
names simultaneously, and the command still exists during delete
traces (if TCL_INTERP_DESTROYED is not set).  However, there is no
mechanism for signaling that an error occurred in a trace procedure,
so great care should be taken that errors do not get silently lost.

.SH "MULTIPLE TRACES"
.PP
It is possible for multiple traces to exist on the same command.
When this happens, all of the trace procedures will be invoked on each
access, in order from most-recently-created to least-recently-created.
Changes to doc/TraceVar.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: TraceVar.3,v 1.4.18.2 2002/06/10 05:33:08 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: TraceVar.3,v 1.4.18.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable
.SH SYNOPSIS
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
.sp
ClientData
\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR
.SH ARGUMENTS
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variable.
.AP char *varName in
Name of variable.  May refer to a scalar variable, to
an array variable with no index, or to an array variable
with a parenthesized index.
If the name references an element of an array, then it
must be in writable memory:  Tcl will make temporary modifications 
to it while looking up the name.
.AP int flags in
OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, 
TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
TCL_TRACE_RESULT_DYNAMIC and TCL_TRACE_RESULT_OBJECT.  
Not all flags are used by all
procedures.  See below for more information.
.AP Tcl_VarTraceProc *proc in
Procedure to invoke whenever one of the traced operations occurs.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.AP char *name1 in
Name of scalar or array variable (without array index).
.AP "CONST char" *name2 in
For a trace on an element of an array, gives the index of the
element.  For traces on scalar variables or on whole arrays,
is NULL.
.AP ClientData prevClientData in
If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or







|



<
<
<










|







31
32
33
34
35
36
37
38
39
40
41



42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
.sp
ClientData
\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR
.SH ARGUMENTS
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variable.
.AP "CONST char" *varName in
Name of variable.  May refer to a scalar variable, to
an array variable with no index, or to an array variable
with a parenthesized index.



.AP int flags in
OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, 
TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
TCL_TRACE_RESULT_DYNAMIC and TCL_TRACE_RESULT_OBJECT.  
Not all flags are used by all
procedures.  See below for more information.
.AP Tcl_VarTraceProc *proc in
Procedure to invoke whenever one of the traced operations occurs.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.AP "CONST char" *name1 in
Name of scalar or array variable (without array index).
.AP "CONST char" *name2 in
For a trace on an element of an array, gives the index of the
element.  For traces on scalar variables or on whole arrays,
is NULL.
.AP ClientData prevClientData in
If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or
Changes to doc/UpVar.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: UpVar.3,v 1.4.2.1 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UpVar, Tcl_UpVar2 \- link one variable to another
.SH SYNOPSIS







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: UpVar.3,v 1.4.2.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UpVar, Tcl_UpVar2 \- link one variable to another
.SH SYNOPSIS
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variables;  also used for error reporting.
.AP "CONST char" *frameName in
Identifies the stack frame containing source variable.
May have any of the forms accepted by
the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR.
.AP char *sourceName in
Name of source variable, in the frame given by \fIframeName\fR.
May refer to a scalar variable or to an array variable with a
parenthesized index.
.AP "CONST char" *destName in
Name of destination variable, which is to be linked to source
variable so that references to \fIdestName\fR
refer to the other variable.  Must not currently exist except as
an upvar-ed variable.
.AP int flags in
Either TCL_GLOBAL_ONLY or 0;  if non-zero, then \fIdestName\fR is
a global variable;  otherwise it is a local to the current procedure
(or global if no procedure is active).
.AP char *name1 in
First part of source variable's name (scalar name, or name of array
without array index).
.AP "CONST char" *name2 in
If source variable is an element of an array, gives the index of the element.
For scalar source variables, is NULL.
.BE








|












|







25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variables;  also used for error reporting.
.AP "CONST char" *frameName in
Identifies the stack frame containing source variable.
May have any of the forms accepted by
the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR.
.AP "CONST char" *sourceName in
Name of source variable, in the frame given by \fIframeName\fR.
May refer to a scalar variable or to an array variable with a
parenthesized index.
.AP "CONST char" *destName in
Name of destination variable, which is to be linked to source
variable so that references to \fIdestName\fR
refer to the other variable.  Must not currently exist except as
an upvar-ed variable.
.AP int flags in
Either TCL_GLOBAL_ONLY or 0;  if non-zero, then \fIdestName\fR is
a global variable;  otherwise it is a local to the current procedure
(or global if no procedure is active).
.AP "CONST char" *name1 in
First part of source variable's name (scalar name, or name of array
without array index).
.AP "CONST char" *name2 in
If source variable is an element of an array, gives the index of the element.
For scalar source variables, is NULL.
.BE

Changes to doc/Utf.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Utf.3,v 1.9.12.2 2002/06/10 05:33:08 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: Utf.3,v 1.9.12.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Utf 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings.
.SH SYNOPSIS
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
to UTF-8, storing the result in a previously-initialized \fBTcl_DString\fR.
You must specify the length of the given Unicode string.
The return value is a pointer to the UTF-8 representation of the
Unicode string.  Storage for the return value is appended to the
end of the \fBTcl_DString\fR.
.PP
\fBTcl_UtfToUniCharDString\fR coverts the given UTF-8 string to Unicode,
storing the result in the previously-initialized \fBTcl_DString\fR.
you may either specify the length of the given UTF-8 string or "-1",
in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
calculate the length.  The return value is a pointer to the Unicode
representation of the UTF-8 string.  Storage for the return value
is appended to the end of the \fBTcl_DString\fR.  The Unicode string
is terminated with a Unicode NULL character.







|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
\fBTcl_UniCharToUtfDString\fR converts the given Unicode string
to UTF-8, storing the result in a previously-initialized \fBTcl_DString\fR.
You must specify the length of the given Unicode string.
The return value is a pointer to the UTF-8 representation of the
Unicode string.  Storage for the return value is appended to the
end of the \fBTcl_DString\fR.
.PP
\fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode,
storing the result in the previously-initialized \fBTcl_DString\fR.
you may either specify the length of the given UTF-8 string or "-1",
in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
calculate the length.  The return value is a pointer to the Unicode
representation of the UTF-8 string.  Storage for the return value
is appended to the end of the \fBTcl_DString\fR.  The Unicode string
is terminated with a Unicode NULL character.
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR.  The length of the source string is \fIlen\fR bytes.  If the
length is negative, all bytes up to the first NULL byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
returns a pointer to the first occurance of the Tcl_UniChar \fIch\fR
in the NULL-terminated UTF-8 string \fIsrc\fR.  The NULL terminator is
considered part of the UTF-8 string.  
.PP
\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings.  It
returns a pointer to the last occurance of the Tcl_UniChar \fIch\fR
in the NULL terminated UTF-8 string \fIsrc\fR.  The NULL terminator is
considered part of the UTF-8 string.  
.PP
Given \fIsrc\fR, a pointer to some location in a UTF-8 string,
\fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the
string.  The caller must not ask for the next character after the last
character in the string.







|




|







208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
.PP
\fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings.  It
returns the number of Tcl_UniChars that are represented by the UTF-8 string
\fIsrc\fR.  The length of the source string is \fIlen\fR bytes.  If the
length is negative, all bytes up to the first NULL byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings.  It
returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR
in the NULL-terminated UTF-8 string \fIsrc\fR.  The NULL terminator is
considered part of the UTF-8 string.  
.PP
\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings.  It
returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR
in the NULL terminated UTF-8 string \fIsrc\fR.  The NULL terminator is
considered part of the UTF-8 string.  
.PP
Given \fIsrc\fR, a pointer to some location in a UTF-8 string,
\fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the
string.  The caller must not ask for the next character after the last
character in the string.
Changes to doc/WrongNumArgs.3.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: WrongNumArgs.3,v 1.3.18.1 2002/02/05 02:21:58 wolfsuit Exp $
'\" 
.so man.macros
.TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments
.SH SYNOPSIS






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: WrongNumArgs.3,v 1.3.18.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments
.SH SYNOPSIS
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
a subcommand.  The command
\fBTcl_GetIndexFromObj\fR will convert the abbreviated string object
into an \fIindexObject\fR.  If an error occurs in the parsing of the
subcommand we would like to use the full subcommand name rather than
the abbreviation.  If the \fBTcl_WrongNumArgs\fR command finds any
\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand
name in the error message instead of the abbreviated name that was
origionally passed in.  Using the above example, lets assume that
\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object
is now an indexObject becasue it was passed to
\fBTcl_GetIndexFromObj\fR.  In this case the error message would be:
.CS
wrong # args: should be "foo barfly fileName count"
.CE

.SH "SEE ALSO"
Tcl_GetIndexFromObj

.SH KEYWORDS
command, error message, wrong number of arguments







|

|










59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
a subcommand.  The command
\fBTcl_GetIndexFromObj\fR will convert the abbreviated string object
into an \fIindexObject\fR.  If an error occurs in the parsing of the
subcommand we would like to use the full subcommand name rather than
the abbreviation.  If the \fBTcl_WrongNumArgs\fR command finds any
\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand
name in the error message instead of the abbreviated name that was
originally passed in.  Using the above example, lets assume that
\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object
is now an indexObject because it was passed to
\fBTcl_GetIndexFromObj\fR.  In this case the error message would be:
.CS
wrong # args: should be "foo barfly fileName count"
.CE

.SH "SEE ALSO"
Tcl_GetIndexFromObj

.SH KEYWORDS
command, error message, wrong number of arguments
Changes to doc/binary.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: binary.n,v 1.7.2.1 2002/06/10 05:33:08 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1997 by Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: binary.n,v 1.7.2.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
binary \- Insert and extract fields from binary strings
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
.CE
will return \fBdghi\fR.
.RE
.IP \fB@\fR 5
Moves the cursor to the absolute location in the output string
specified by \fIcount\fR.  Position 0 refers to the first byte in the
output string.  If \fIcount\fR refers to a position beyond the last
byte stored so far, then null bytes will be placed in the unitialized
locations and the cursor will be placed at the specified location.  If
\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of
the output string.  If \fIcount\fR is omitted, then an error will be
generated.  This type does not consume an argument. For example,
.RS
.CS
\fBbinary format a5@2a1@*a3@10a1 abcde f ghi j\fR







|







279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
.CE
will return \fBdghi\fR.
.RE
.IP \fB@\fR 5
Moves the cursor to the absolute location in the output string
specified by \fIcount\fR.  Position 0 refers to the first byte in the
output string.  If \fIcount\fR refers to a position beyond the last
byte stored so far, then null bytes will be placed in the uninitialized
locations and the cursor will be placed at the specified location.  If
\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of
the output string.  If \fIcount\fR is omitted, then an error will be
generated.  This type does not consume an argument. For example,
.RS
.CS
\fBbinary format a5@2a1@*a3@10a1 abcde f ghi j\fR
Changes to doc/concat.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22


23
24
25
26
27
28
29
30
31
32
33
34








35
36
37
38
39
40
41
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: concat.n,v 1.3 2000/09/07 14:27:46 poenitz Exp $
'\" 
.so man.macros
.TH concat n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
concat \- Join lists together
.SH SYNOPSIS
\fBconcat\fI \fR?\fIarg arg ...\fR?
.BE

.SH DESCRIPTION
.PP
This command treats each argument as a list and concatenates them


into a single list.
It also eliminates leading and trailing spaces in the \fIarg\fR's
and adds a single separator space between \fIarg\fR's.
It permits any number of arguments.  For example,
the command
.CS
\fBconcat a b {c d e} {f {g h}}\fR
.CE
will return
.CS
\fBa b c d e f {g h}\fR
.CE








as its result.
.PP
If no \fIarg\fRs are supplied, the result is an empty string.

.SH "SEE ALSO"
append(n), eval(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
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: concat.n,v 1.3.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH concat n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
concat \- Join lists together
.SH SYNOPSIS
\fBconcat\fI \fR?\fIarg arg ...\fR?
.BE

.SH DESCRIPTION
.PP
This command joins each of its arguments together with spaces after
trimming leading and trailing spaces from each of them.  If all the
arguments are lists, this has the same effect as concatenating them
into a single list.


It permits any number of arguments.  For example, the command

.CS
\fBconcat a b {c d e} {f {g h}}\fR
.CE
will return
.CS
\fBa b c d e f {g h}\fR
.CE
as its result, and
.CS
\fBconcat " a b {c   " d "  e} f"\fR
.CE
will return
.CS
\fBa b {c d e} f\fR
.CE
as its result.
.PP
If no \fIarg\fRs are supplied, the result is an empty string.

.SH "SEE ALSO"
append(n), eval(n)

Changes to doc/dde.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2001 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: dde.n,v 1.7 2001/08/22 23:56:14 hobbs Exp $
'\" 
.so man.macros
.TH dde n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
dde \- Execute a Dynamic Data Exchange command
.SH SYNOPSIS
.sp
\fBpackage require dde 1.2\fR







|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2001 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: dde.n,v 1.7.8.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH dde n 1.2 dde "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
dde \- Execute a Dynamic Data Exchange command
.SH SYNOPSIS
.sp
\fBpackage require dde 1.2\fR
Changes to doc/expr.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: expr.n,v 1.5.14.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH expr n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
expr \- Evaluate an expression







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-2000 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: expr.n,v 1.5.14.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH expr n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
expr \- Evaluate an expression
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
.TP
\fBsqrt(\fIarg\fB)\fR
Returns the square root of \fIarg\fR.  \fIArg\fR must be non-negative.
.TP
\fBsrand(\fIarg\fB)\fR
The \fIarg\fR, which must be an integer, is used to reset the seed for
the random number generator.  Returns the first random number from
that seed.  Each interpreter has it's 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







|







298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
.TP
\fBsqrt(\fIarg\fB)\fR
Returns the square root of \fIarg\fR.  \fIArg\fR must be non-negative.
.TP
\fBsrand(\fIarg\fB)\fR
The \fIarg\fR, which must be an integer, is used to reset the seed for
the random number generator.  Returns the first random number from
that seed.  Each interpreter has its own seed.
.TP
\fBtan(\fIarg\fB)\fR
Returns the tangent of \fIarg\fR, measured in radians.
.TP
\fBtanh(\fIarg\fB)\fR
Returns the hyperbolic tangent of \fIarg\fR.
.TP
Changes to doc/fconfigure.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\" 
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: fconfigure.n,v 1.5.4.1 2002/02/05 02:21:58 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\" 
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: fconfigure.n,v 1.5.4.2 2002/08/20 20:25:24 das Exp $
'\"
.so man.macros
.TH fconfigure n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
fconfigure \- Set and get options on a channel
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will
automatically flush output for the channel whenever a newline character
is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush
automatically after every output operation.  The default is for
\fB\-buffering\fR to be set to \fBfull\fR except for channels that
connect to terminal-like devices; for these channels the initial setting
is \fBline\fR.  Additionally, \fBstdin\fR and \fBstdout\fR are
intially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR.
.TP
\fB\-buffersize\fR \fInewSize\fR
.
\fINewvalue\fR must be an integer; its value is used to set the size of
buffers, in bytes, subsequently allocated for this channel to store input
or output. \fINewvalue\fR must be between ten and one million, allowing
buffers of ten to one million bytes in size.







|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will
automatically flush output for the channel whenever a newline character
is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush
automatically after every output operation.  The default is for
\fB\-buffering\fR to be set to \fBfull\fR except for channels that
connect to terminal-like devices; for these channels the initial setting
is \fBline\fR.  Additionally, \fBstdin\fR and \fBstdout\fR are
initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR.
.TP
\fB\-buffersize\fR \fInewSize\fR
.
\fINewvalue\fR must be an integer; its value is used to set the size of
buffers, in bytes, subsequently allocated for this channel to store input
or output. \fINewvalue\fR must be between ten and one million, allowing
buffers of ten to one million bytes in size.
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
.
(Windows and Unix). This option is used to setup automatic handshake
control. Note that not all handshake types maybe supported by your operating
system. The \fItype\fR parameter is case-independent.

If \fItype\fR is \fBnone\fR then any handshake is switched off.
\fBrtscts\fR activates hardware handshake. Hardware handshake signals
are decribed below.
For software handshake \fBxonxoff\fR the handshake characters can be redefined
with \fB-xchar\fR.
An additional hardware handshake \fBdtrdsr\fR is available only under Windows.
There is no default handshake configuration, the initial value depends
on your operating system settings.
The \fB-handshake\fR option cannot be queried.

.TP
\fB\-queue\fR
.
(Windows and Unix). The \fB-queue\fR option can only be queried.
It returns a list of two integers representing the current number
of bytes in the input and output queue respectively.

.TP
\fB\-timeout\fR \fImsec\fR
.
(Windows and Unix). This option is used to set the timeout for blocking
read operations. It specifies the maximum interval between the
receiption of two bytes in milliseconds.
For Unix systems the granularity is 100 milliseconds.
The \fB-timeout\fR option does not affect write operations or
nonblocking reads.
This option cannot be queried.

.TP
\fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR







|



















|







227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
.
(Windows and Unix). This option is used to setup automatic handshake
control. Note that not all handshake types maybe supported by your operating
system. The \fItype\fR parameter is case-independent.

If \fItype\fR is \fBnone\fR then any handshake is switched off.
\fBrtscts\fR activates hardware handshake. Hardware handshake signals
are described below.
For software handshake \fBxonxoff\fR the handshake characters can be redefined
with \fB-xchar\fR.
An additional hardware handshake \fBdtrdsr\fR is available only under Windows.
There is no default handshake configuration, the initial value depends
on your operating system settings.
The \fB-handshake\fR option cannot be queried.

.TP
\fB\-queue\fR
.
(Windows and Unix). The \fB-queue\fR option can only be queried.
It returns a list of two integers representing the current number
of bytes in the input and output queue respectively.

.TP
\fB\-timeout\fR \fImsec\fR
.
(Windows and Unix). This option is used to set the timeout for blocking
read operations. It specifies the maximum interval between the
reception of two bytes in milliseconds.
For Unix systems the granularity is 100 milliseconds.
The \fB-timeout\fR option does not affect write operations or
nonblocking reads.
This option cannot be queried.

.TP
\fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
a "Carrier" signal.
.IP \fBRI(input)\fR
\fBRing Indicator:\fR Goes active when the modem detects an incoming call.
.IP \fBBREAK\fR
A BREAK condition is not a hardware signal line, but a logical zero on the
TXD or RXD lines for a long period of time, usually 250 to 500
milliseconds.  Normally a receive or transmit data signal stays at the mark
(on=1) voltage until the next character is tranferred. A BREAK is sometimes
used to reset the communications line or change the operating mode of
cummunications hardware.
.RE

.SH "ERROR CODES (Windows only)"
.PP
A lot of different errors may occur during serial read operations or during
event polling in background. The external device may have been switched
off, the data lines may be noisy, system buffers may overrun or your mode







|

|







353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
a "Carrier" signal.
.IP \fBRI(input)\fR
\fBRing Indicator:\fR Goes active when the modem detects an incoming call.
.IP \fBBREAK\fR
A BREAK condition is not a hardware signal line, but a logical zero on the
TXD or RXD lines for a long period of time, usually 250 to 500
milliseconds.  Normally a receive or transmit data signal stays at the mark
(on=1) voltage until the next character is transferred. A BREAK is sometimes
used to reset the communications line or change the operating mode of
communications hardware.
.RE

.SH "ERROR CODES (Windows only)"
.PP
A lot of different errors may occur during serial read operations or during
event polling in background. The external device may have been switched
off, the data lines may be noisy, system buffers may overrun or your mode
Changes to doc/file.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: file.n,v 1.8.8.2 2002/06/10 05:33:08 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: file.n,v 1.8.8.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH file n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
file \- Manipulate file names and attributes
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
accessed.  If \fItime\fR is specified, it is an access time to set
for the file.  The time is measured in the standard POSIX fashion as
seconds from a fixed starting time (often January 1, 1970).  If the file
doesn't exist or its access time cannot be queried or set then an error is
generated.  On Windows, FAT file systems do not support access time.
.TP
\fBfile attributes \fIname\fR
.br
\fBfile attributes \fIname\fR ?\fBoption\fR?
.br
\fBfile attributes \fIname\fR ?\fBoption value option value...\fR?
.RS
This subcommand returns or sets platform specific values associated
with a file. The first form returns a list of the platform specific
flags and their values. The second form returns the value for the
specific option. The third form sets one or more of the values. The
values are as follows:







|

|







32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
accessed.  If \fItime\fR is specified, it is an access time to set
for the file.  The time is measured in the standard POSIX fashion as
seconds from a fixed starting time (often January 1, 1970).  If the file
doesn't exist or its access time cannot be queried or set then an error is
generated.  On Windows, FAT file systems do not support access time.
.TP
\fBfile attributes \fIname\fR
.TP
\fBfile attributes \fIname\fR ?\fBoption\fR?
.TP
\fBfile attributes \fIname\fR ?\fBoption value option value...\fR?
.RS
This subcommand returns or sets platform specific values associated
with a file. The first form returns a list of the platform specific
flags and their values. The second form returns the value for the
specific option. The third form sets one or more of the values. The
values are as follows:
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
If \fIpattern\fR isn't specified, returns a list of names of all
registered open channels in this interpreter.  If \fIpattern\fR is
specified, only those names matching \fIpattern\fR are returned.  Matching
is determined using the same rules as for \fBstring match\fR.
.VE
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
.br
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form makes a copy of the file or directory \fIsource\fR under
the pathname \fItarget\fR. If \fItarget\fR is an existing directory,
then the second form is used.  The second form makes a copy inside
\fItargetDir\fR of each \fIsource\fR file listed.  If a directory is
specified as a \fIsource\fR, then the contents of the directory will be







|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
If \fIpattern\fR isn't specified, returns a list of names of all
registered open channels in this interpreter.  If \fIpattern\fR is
specified, only those names matching \fIpattern\fR are returned.  Matching
is determined using the same rules as for \fBstring match\fR.
.VE
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form makes a copy of the file or directory \fIsource\fR under
the pathname \fItarget\fR. If \fItarget\fR is an existing directory,
then the second form is used.  The second form makes a copy inside
\fItargetDir\fR of each \fIsource\fR file listed.  If a directory is
specified as a \fIsource\fR, then the contents of the directory will be
186
187
188
189
190
191
192































193
194
195
196
197
198
199
.CE
returns \fB/foo/bar\fR.
.PP
Note that any of the names can contain separators, and that the result
is always canonical for the current platform: \fB/\fR for Unix and
Windows, and \fB:\fR for Macintosh.
.RE































.TP
\fBfile lstat \fIname varName\fR
.
Same as \fBstat\fR option (see below) except uses the \fIlstat\fR
kernel call instead of \fIstat\fR.  This means that if \fIname\fR
refers to a symbolic link the information returned in \fIvarName\fR
is for the link rather than the file it refers to.  On systems that







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
.CE
returns \fB/foo/bar\fR.
.PP
Note that any of the names can contain separators, and that the result
is always canonical for the current platform: \fB/\fR for Unix and
Windows, and \fB:\fR for Macintosh.
.RE
.TP
\fBfile link ?\fI-linktype\fR? \fIlinkName\fR ?\fItarget\fR?
.
If only one argument is given, that argument is assumed to be
\fIlinkName\fR, and this command returns the value of the link given by
\fIlinkName\fR (i.e. the name of the file it points to).  If
\fIlinkName\fR isn't a link or its value cannot be read (as, for example,
seems to be the case with hard links, which look just like ordinary
files), then an error is returned.
.
If 2 arguments are given, then these are assumed to be \fIlinkName\fR and
\fItarget\fR. If \fIlinkName\fR already exists, or if \fItarget\fR
doesn't exist, an error will be returned.  Otherwise, Tcl creates a new
link called \fIlinkName\fR which points to the existing filesystem object
at \fItarget\fR, where the type of the link is platform-specific (on Unix
a symbolic link will be the default).  This is useful for the case where
the user wishes to create a link in a cross-platform way, and doesn't
care what type of link is created.
.
If the user wishes to make a link of a specific type only, (and signal an
error if for some reason that is not possible), then the optional
\fI-linktype\fR argument should be given.  Accepted values for
\fI-linktype\fR are "-symbolic" and "-hard".
.
When creating links on filesystems that either do not support any links,
or do not support the specific type requested, an error message will be
returned.  In particular Windows 95, 98 and ME do not support any links
at present, but most Unix platforms support both symbolic and hard links
(the latter for files only), MacOS supports symbolic links and Windows
NT/2000/XP (on NTFS drives) support symbolic directory links and hard
file links.
.TP
\fBfile lstat \fIname varName\fR
.
Same as \fBstat\fR option (see below) except uses the \fIlstat\fR
kernel call instead of \fIstat\fR.  This means that if \fIname\fR
refers to a symbolic link the information returned in \fIvarName\fR
is for the link rather than the file it refers to.  On systems that
222
223
224
225
226
227
228

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
.
Returns the platform-specific name of the file. This is useful if the
filename is needed to pass to a platform-specific call, such as exec
under Windows or AppleScript on the Macintosh.
.TP
\fBfile normalize \fIname\fR
.

Returns a unique normalised path representation for the file-system 
object (file, directory, link, etc), whose string value can be used as 
a unique identifier for it.  A normalized path is one which has all '../', './' 
removed.  Also it is one which is in the ``standard'' format for the native 
platform.  On MacOS, Unix, this means the segments leading up to the path 
must be free of symbolic links/aliases (but the very last path component 
may be a symbolic link), and on Windows it also means means we want the
long form (when running Win NT/2000/XP) or the short form (when running Win
95/98) with that form's case-dependence (which gives us a unique,
case-dependent path).  The one exception concerning the last link in the
path is necessary, because Tcl or the user may wish to operate on the
actual symbolic link itself (for example 'file delete', 'file rename', 'file copy'
are defined to operate on symbolic links, not on the things that they point to).

.PP
Note that this means normalized paths are different on old Windows
operating systems (95/98) and new Windows operating systems
(NT/2000/XP).  This is necessary because the APIs  
to produce a long normalized path in older operating systems are 
unfortunately very slow.
.TP
\fBfile owned \fIname\fR 
.
Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR
otherwise.
.TP
\fBfile pathtype \fIname\fR







>
|
|
|
|
|
|
|
<
|
|
|
|
|
>
|
<
<
<
<
<







253
254
255
256
257
258
259
260
261
262
263
264
265
266
267

268
269
270
271
272
273
274





275
276
277
278
279
280
281
.
Returns the platform-specific name of the file. This is useful if the
filename is needed to pass to a platform-specific call, such as exec
under Windows or AppleScript on the Macintosh.
.TP
\fBfile normalize \fIname\fR
.
.RS
Returns a unique normalised path representation for the file-system
object (file, directory, link, etc), whose string value can be used as a
unique identifier for it.  A normalized path is one which has all '../',
'./' removed.  Also it is one which is in the ``standard'' format for the
native platform.  On MacOS, Unix, this means the segments leading up to
the path must be free of symbolic links/aliases (but the very last path
component may be a symbolic link), and on Windows it also means means we

want the long form with that form's case-dependence (which gives us a
unique, case-dependent path).  The one exception concerning the last link
in the path is necessary, because Tcl or the user may wish to operate on
the actual symbolic link itself (for example 'file delete', 'file
rename', 'file copy' are defined to operate on symbolic links, not on the
things that they point to).
.RE





.TP
\fBfile owned \fIname\fR 
.
Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR
otherwise.
.TP
\fBfile pathtype \fIname\fR
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
.TP
\fBfile rootname \fIname\fR
.
Returns all of the characters in \fIname\fR up to but not including the
last ``.'' character in the last component of name.  If the last
component of \fIname\fR doesn't contain a dot, then returns \fIname\fR.
.TP
\fBfile separator ?\fIname\fR?
.
If no argument is given, returns the character which is used to separate 
path segments for native files on this platform.  If a path is given,
the filesystem responsible for that path is asked to return its
separator character.  If no file system accepts \fIname\fR, an error
is generated.
.TP







|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
.TP
\fBfile rootname \fIname\fR
.
Returns all of the characters in \fIname\fR up to but not including the
last ``.'' character in the last component of name.  If the last
component of \fIname\fR doesn't contain a dot, then returns \fIname\fR.
.TP
\fBfile separator\fR ?\fIname\fR?
.
If no argument is given, returns the character which is used to separate 
path segments for native files on this platform.  If a path is given,
the filesystem responsible for that path is asked to return its
separator character.  If no file system accepts \fIname\fR, an error
is generated.
.TP
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
Returns a list whose elements are the path components in \fIname\fR.  The
first element of the list will have the same path type as \fIname\fR.
All other elements will be relative.  Path separators will be discarded
unless they are needed ensure that an element is unambiguously relative.
For example, under Unix
.RS
.CS
\fBfile split /foo/~bar/baz\fR
.CE
returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands
that use the third component do not attempt to perform tilde
substitution.
.RE
.TP
\fBfile stat  \fIname varName\fR







|







345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
Returns a list whose elements are the path components in \fIname\fR.  The
first element of the list will have the same path type as \fIname\fR.
All other elements will be relative.  Path separators will be discarded
unless they are needed ensure that an element is unambiguously relative.
For example, under Unix
.RS
.CS
file split /foo/~bar/baz
.CE
returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands
that use the third component do not attempt to perform tilde
substitution.
.RE
.TP
\fBfile stat  \fIname varName\fR
Changes to doc/glob.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: glob.n,v 1.11 2001/08/24 16:43:25 vincentdarley 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: glob.n,v 1.11.8.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH glob n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
glob \- Return names of files that match patterns
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
The second form specifies types where all the types given must match.
These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and
\fIreadonly\fR, \fIhidden\fR as special permission cases.  On the
Macintosh, MacOS types and creators are also supported, where any item
which is four characters long is assumed to be a MacOS type
(e.g. \fBTEXT\fR).  Items which are of the form \fI{macintosh type XXXX}\fR
or \fI{macintosh creator XXXX}\fR will match types or creators
respectively.  Unrecognised types, or specifications of multiple MacOS
types/creators will signal an error.
.PP
The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
regular files OR directories that have both read AND write permissions.
The following are equivalent:
.RS
.CS







|







83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
The second form specifies types where all the types given must match.
These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and
\fIreadonly\fR, \fIhidden\fR as special permission cases.  On the
Macintosh, MacOS types and creators are also supported, where any item
which is four characters long is assumed to be a MacOS type
(e.g. \fBTEXT\fR).  Items which are of the form \fI{macintosh type XXXX}\fR
or \fI{macintosh creator XXXX}\fR will match types or creators
respectively.  Unrecognized types, or specifications of multiple MacOS
types/creators will signal an error.
.PP
The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
regular files OR directories that have both read AND write permissions.
The following are equivalent:
.RS
.CS
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
domain server.  Otherwise, user account information is obtained from
the local computer.  On Windows 95 and 98, \fBglob\fR accepts patterns
like ``.../'' and ``..../'' for successively higher up parent directories.

.
Since the backslash character has a special meaning to the glob 
command, glob patterns containing Windows style path separators need 
special care. The pattern \fIC:\e\efoo\e\e*\fR is interepreted as 
\fIC:\efoo\e*\fR where \fI\ef\fR will match the single character \fIf\fR 
and \fI\e*\fR will match the single character \fI*\fR and will not be 
interpreted as a wildcard character. One solution to this problem is 
to use the Unix style forward slash as a path separator. Windows style 
paths can be converted to Unix style paths with the command \fBfile
join $path\fR (or \fBfile normalize $path\fR in Tcl 8.4). 
.TP 







|







166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
domain server.  Otherwise, user account information is obtained from
the local computer.  On Windows 95 and 98, \fBglob\fR accepts patterns
like ``.../'' and ``..../'' for successively higher up parent directories.

.
Since the backslash character has a special meaning to the glob 
command, glob patterns containing Windows style path separators need 
special care. The pattern \fIC:\e\efoo\e\e*\fR is interpreted as 
\fIC:\efoo\e*\fR where \fI\ef\fR will match the single character \fIf\fR 
and \fI\e*\fR will match the single character \fI*\fR and will not be 
interpreted as a wildcard character. One solution to this problem is 
to use the Unix style forward slash as a path separator. Windows style 
paths can be converted to Unix style paths with the command \fBfile
join $path\fR (or \fBfile normalize $path\fR in Tcl 8.4). 
.TP 
Changes to doc/global.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: global.n,v 1.3 2000/11/21 15:56:21 dkf Exp $
'\" 
.so man.macros
.TH global n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
global \- Access global variables







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: global.n,v 1.3.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH global n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
global \- Access global variables
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
rather than local ones.
Global variables are variables in the global namespace.
For the duration of the current procedure
(and only while executing in the current procedure),
any reference to any of the \fIvarname\fRs
will refer to the global variable by the same name.
.PP
Please note that this is done by creating local variables that are
linked to the global variables, and therefore that these variables
will be listed by \fBinfo locals\fR like all other local variables.

.SH "SEE ALSO"
namespace(n), upvar(n), variable(n)

.SH KEYWORDS
global, namespace, procedure, variable







<
<
<






24
25
26
27
28
29
30



31
32
33
34
35
36
rather than local ones.
Global variables are variables in the global namespace.
For the duration of the current procedure
(and only while executing in the current procedure),
any reference to any of the \fIvarname\fRs
will refer to the global variable by the same name.
.PP




.SH "SEE ALSO"
namespace(n), upvar(n), variable(n)

.SH KEYWORDS
global, namespace, procedure, variable
Changes to doc/http.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
'\"
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: http.n,v 1.14.8.1 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH "Http" n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Http \- Client-side implementation of the HTTP/1.0 protocol.
.SH SYNOPSIS
\fBpackage require http ?2.4?\fR
.sp
\fB::http::config \fI?options?\fR
.sp
\fB::http::geturl \fIurl ?options?\fR
.sp







|


|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
'\"
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: http.n,v 1.14.8.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH "http" n 2.4 http "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
http \- Client-side implementation of the HTTP/1.0 protocol.
.SH SYNOPSIS
\fBpackage require http ?2.4?\fR
.sp
\fB::http::config \fI?options?\fR
.sp
\fB::http::geturl \fIurl ?options?\fR
.sp
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
.SH DESCRIPTION
.PP
The \fBhttp\fR package provides the client side of the HTTP/1.0
protocol.  The package implements the GET, POST, and HEAD operations
of HTTP/1.0.  It allows configuration of a proxy host to get through
firewalls.  The package is compatible with the \fBSafesock\fR security
policy, so it can be used by untrusted applets to do URL fetching from
a restricted set of hosts. This package can be extened to support
additional HTTP transport protocols, such as HTTPS, by providing
a custom \fBsocket\fR command, via \fBhttp::register\fR.
.PP
The \fB::http::geturl\fR procedure does a HTTP transaction.
Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
is performed.  
The return value of \fB::http::geturl\fR is a token for the transaction.







|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
.SH DESCRIPTION
.PP
The \fBhttp\fR package provides the client side of the HTTP/1.0
protocol.  The package implements the GET, POST, and HEAD operations
of HTTP/1.0.  It allows configuration of a proxy host to get through
firewalls.  The package is compatible with the \fBSafesock\fR security
policy, so it can be used by untrusted applets to do URL fetching from
a restricted set of hosts. This package can be extended to support
additional HTTP transport protocols, such as HTTPS, by providing
a custom \fBsocket\fR command, via \fBhttp::register\fR.
.PP
The \fB::http::geturl\fR procedure does a HTTP transaction.
Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
is performed.  
The return value of \fB::http::geturl\fR is a token for the transaction.
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
the proxy server and proxy port.  Otherwise the filter should return
an empty list.  The default filter returns the values of the
\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
non-empty.
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request.  The default
is \fB"Tcl http client package 2.2."\fR
.RE
.TP
\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP? 
The \fB::http::geturl\fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
otherwise, a GET operation is performed.  The \fB::http::geturl\fR command







|







106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
the proxy server and proxy port.  Otherwise the filter should return
an empty list.  The default filter returns the values of the
\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
non-empty.
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request.  The default
is \fB"Tcl http client package 2.4."\fR
.RE
.TP
\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP? 
The \fB::http::geturl\fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
otherwise, a GET operation is performed.  The \fB::http::geturl\fR command
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
For asynchronous \fB::http::geturl\fP calls, all of the above error
situations apply, except that if there's any error while 
reading the
HTTP reply headers or data, no exception is thrown.  This is because
after writing the HTTP headers, \fB::http::geturl\fP returns, and the
rest of the HTTP transaction occurs in the background.  The command
callback can check if any error occurred during the read by calling
\fB::http::status\fP to check the status and if it's \fIerror\fP,
calling \fB::http::error\fP to get the error message.
.PP
Alternatively, if the main program flow reaches a point where it needs
to know the result of the asynchronous HTTP request, it can call
\fB::http::wait\fP and then check status and error, just as the
callback does.
.PP







|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
For asynchronous \fB::http::geturl\fP calls, all of the above error
situations apply, except that if there's any error while 
reading the
HTTP reply headers or data, no exception is thrown.  This is because
after writing the HTTP headers, \fB::http::geturl\fP returns, and the
rest of the HTTP transaction occurs in the background.  The command
callback can check if any error occurred during the read by calling
\fB::http::status\fP to check the status and if its \fIerror\fP,
calling \fB::http::error\fP to get the error message.
.PP
Alternatively, if the main program flow reaches a point where it needs
to know the result of the asynchronous HTTP request, it can call
\fB::http::wait\fP and then check status and error, just as the
callback does.
.PP
Changes to doc/info.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1998-2000 Ajuba Solutions
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: info.n,v 1.7 2001/05/30 08:57:06 dkf Exp $
'\" 
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
info \- Return information about the state of the Tcl interpreter









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1998-2000 Ajuba Solutions
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: info.n,v 1.7.10.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
info \- Return information about the state of the Tcl interpreter
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
To get a list of just the packages in the current interpreter, specify
an empty string for the \fIinterp\fR argument.
.TP
\fBinfo locals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined local variables, including arguments to the
current procedure, if any.
Variables defined with the \fBglobal\fR and \fBupvar\fR commands
will not be returned.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned.  Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo nameofexecutable\fR
Returns the full path name of the binary file from which the application
was invoked.  If Tcl was unable to identify the file, then an empty







|
|







136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
To get a list of just the packages in the current interpreter, specify
an empty string for the \fIinterp\fR argument.
.TP
\fBinfo locals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined local variables, including arguments to the
current procedure, if any.
Variables defined with the \fBglobal\fR, \fBupvar\fR  and
\fBvariable\fR commands will not be returned.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned.  Matching is determined using the same rules as for
\fBstring match\fR.
.TP
\fBinfo nameofexecutable\fR
Returns the full path name of the binary file from which the application
was invoked.  If Tcl was unable to identify the file, then an empty
Changes to doc/interp.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: interp.n,v 1.7.8.1 2002/06/10 05:33:08 wolfsuit 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: interp.n,v 1.7.8.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
interp \- Create and manipulate Tcl interpreters
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
.TP
\fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
Makes the hidden command \fIhiddenName\fR exposed, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in the interpreter
denoted by \fIpath\fR.
If an exposed command with the targetted name already exists, this command
fails.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
\fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
Makes the exposed command \fIexposedCmdName\fR hidden, renaming
it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if
\fIhiddenCmdName\fR is not given, in the interpreter denoted 
by \fIpath\fR.
If a hidden command with the targetted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can 
not contain namespace qualifiers, or an error is raised.
Commands to be hidden by \fBinterp hide\fR are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.







|








|







173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
.TP
\fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
Makes the hidden command \fIhiddenName\fR exposed, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in the interpreter
denoted by \fIpath\fR.
If an exposed command with the targeted name already exists, this command
fails.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
\fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
Makes the exposed command \fIexposedCmdName\fR hidden, renaming
it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if
\fIhiddenCmdName\fR is not given, in the interpreter denoted 
by \fIpath\fR.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can 
not contain namespace qualifiers, or an error is raised.
Commands to be hidden by \fBinterp hide\fR are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
.VS "" BR
.TP
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIslave\fR.
If an exposed command with the targetted name already exists, this command
fails.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
This command hides the exposed command \fIexposedCmdName\fR, renaming it to 
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
the argument is not given, in the \fIslave\fR interpreter.
If a hidden command with the targetted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can 
not contain namespace qualifiers, or an error is raised.
Commands to be hidden are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.







|







|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
.VS "" BR
.TP
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIslave\fR.
If an exposed command with the targeted name already exists, this command
fails.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
This command hides the exposed command \fIexposedCmdName\fR, renaming it to 
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
the argument is not given, in the \fIslave\fR interpreter.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can 
not contain namespace qualifiers, or an error is raised.
Commands to be hidden are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
hidden functionality in themselves or their descendants.
.PP
The set of hidden commands in an interpreter can be manipulated by a trusted
interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp
expose\fR command moves a hidden command to the
set of exposed commands in the interpreter identified by \fIpath\fR,
potentially renaming the command in the process. If an exposed command by
the targetted name already exists, the operation fails. Similarly,
\fBinterp hide\fR moves an exposed command to the set of hidden commands in
that interpreter. Safe interpreters are not allowed to move commands
between the set of hidden and exposed commands, in either themselves or
their descendants.
.PP
Currently, the names of hidden commands cannot contain namespace
qualifiers, and you must first rename a command in a namespace to the







|







580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
hidden functionality in themselves or their descendants.
.PP
The set of hidden commands in an interpreter can be manipulated by a trusted
interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp
expose\fR command moves a hidden command to the
set of exposed commands in the interpreter identified by \fIpath\fR,
potentially renaming the command in the process. If an exposed command by
the targeted name already exists, the operation fails. Similarly,
\fBinterp hide\fR moves an exposed command to the set of hidden commands in
that interpreter. Safe interpreters are not allowed to move commands
between the set of hidden and exposed commands, in either themselves or
their descendants.
.PP
Currently, the names of hidden commands cannot contain namespace
qualifiers, and you must first rename a command in a namespace to the
Changes to doc/load.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: load.n,v 1.6 2000/09/07 14:27:49 poenitz 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.






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: load.n,v 1.6.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH load n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
load \- Load machine code and initialize new commands.
125
126
127
128
129
130
131
132
133
134
135
.PP
If the same file is \fBload\fRed by different \fIfileName\fRs, it will
be loaded into the process's address space multiple times.  The
behavior of this varies from system to system (some systems may
detect the redundant loads, others may not).

.SH "SEE ALSO"
\fBinfo sharedlibextension\fR, Tcl_StaticPackage(3), safe(n)

.SH KEYWORDS
binary code, loading, safe interpreter, shared library







|



125
126
127
128
129
130
131
132
133
134
135
.PP
If the same file is \fBload\fRed by different \fIfileName\fRs, it will
be loaded into the process's address space multiple times.  The
behavior of this varies from system to system (some systems may
detect the redundant loads, others may not).

.SH "SEE ALSO"
info sharedlibextension, Tcl_StaticPackage(3), safe(n)

.SH KEYWORDS
binary code, loading, safe interpreter, shared library
Changes to doc/lsearch.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lsearch.n,v 1.7.6.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH lsearch n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lsearch \- See if a list contains a particular element








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lsearch.n,v 1.7.6.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH lsearch n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lsearch \- See if a list contains a particular element
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
and \fBend\-\fIinteger\fR refers to the last element in the list minus
the specified integer offset.
.VE 8.4
.PP
If \fIoption\fR is omitted then it defaults to \fB\-glob\fR.  If more
than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and
\fB\-sorted\fR is specified, whichever option is specified last takes
precendence.  If more than one of \fB\-ascii\fR, \fB\-dictionary\fR,
\fB\-integer\fR and \fB\-real\fR is specified, the option specified
last takes precendence.  If more than one of \fB\-increasing\fR and
\fB\-decreasing\fR is specified, the option specified last takes
precedence.

.SH EXAMPLES
.VS 8.4

.CS
lsearch {a b c d e} c => 2
lsearch -all {a b c a b c} c => 2 5
lsearch -data {a20 b35 c47} b* => b35
lsearch -data -not {a20 b35 c47} b* => a20
lsearch -all -data -not {a20 b35 c47} b* => a20 c47
lsearch -all -not {a20 b35 c47} b* => 0 2
lsearch -start 3 {a b c a b c} c => 5
.CE
.VE 8.4

.SH "SEE ALSO"
.VS 8.4
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), 
lset(n), lsort(n), lrange(n), lreplace(n)
.VE

.SH KEYWORDS
list, match, pattern, regular expression, search, string







|

|



<

>



|
|
|













101
102
103
104
105
106
107
108
109
110
111
112
113

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
and \fBend\-\fIinteger\fR refers to the last element in the list minus
the specified integer offset.
.VE 8.4
.PP
If \fIoption\fR is omitted then it defaults to \fB\-glob\fR.  If more
than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and
\fB\-sorted\fR is specified, whichever option is specified last takes
precedence.  If more than one of \fB\-ascii\fR, \fB\-dictionary\fR,
\fB\-integer\fR and \fB\-real\fR is specified, the option specified
last takes precedence.  If more than one of \fB\-increasing\fR and
\fB\-decreasing\fR is specified, the option specified last takes
precedence.


.VS 8.4
.SH EXAMPLES
.CS
lsearch {a b c d e} c => 2
lsearch -all {a b c a b c} c => 2 5
lsearch -inline {a20 b35 c47} b* => b35
lsearch -inline -not {a20 b35 c47} b* => a20
lsearch -all -inline -not {a20 b35 c47} b* => a20 c47
lsearch -all -not {a20 b35 c47} b* => 0 2
lsearch -start 3 {a b c a b c} c => 5
.CE
.VE 8.4

.SH "SEE ALSO"
.VS 8.4
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), 
lset(n), lsort(n), lrange(n), lreplace(n)
.VE

.SH KEYWORDS
list, match, pattern, regular expression, search, string
Changes to doc/lset.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'\"
'\" Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lset.n,v 1.2.4.1 2002/02/05 02:21:58 wolfsuit Exp $
'\" 
.so man.macros
.TH lset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lset \- Change an element in a list
.SH SYNOPSIS
\fBlset \fIlist ?index...? newValue\fR
.BE
.SH DESCRIPTION
.PP
The \fBlset\fP command accepts a parameter, \fIlist\fP, which
it interprets as the name of a variable containing a Tcl list. 
It also accepts zero or more \fIindices\fP into
the list.  The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
Finally, it acccepts a new value for an element of \fIlist\fP.
.PP
If no indices are presented, the command takes the form:
.CS
lset list newValue
.CE
or
.CS






|


















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
'\"
'\" Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: lset.n,v 1.2.4.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH lset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
lset \- Change an element in a list
.SH SYNOPSIS
\fBlset \fIlist ?index...? newValue\fR
.BE
.SH DESCRIPTION
.PP
The \fBlset\fP command accepts a parameter, \fIlist\fP, which
it interprets as the name of a variable containing a Tcl list. 
It also accepts zero or more \fIindices\fP into
the list.  The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
Finally, it accepts a new value for an element of \fIlist\fP.
.PP
If no indices are presented, the command takes the form:
.CS
lset list newValue
.CE
or
.CS
72
73
74
75
76
77
78

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
than or equal to zero.  The integer appearing in each \fIindex\fR
argument must be strictly less than the length of the corresponding
list.  In other words, the \fBlset\fR command cannot change the size
of a list.  If an index is outside the permitted range, an error is reported.
.SH EXAMPLES
In each of these examples, the initial value of \fIx\fP is:
.CS

{a b c} {d e f} {g h i}
.CE
The indicated return value also becomes the new value of \fIx\fP.
.CS
lset x {j k l} => j k l
lset x {} {j k l} => j k l
lset x 0 j => j {d e f} {g h i}
lset x 2 j => {a b c} {d e f} j
lset x end j => {a b c} {d e f} j
lset x end-1 j => {a b c} j {d e f}
lset x 2 1 j => {a b c} {d e f} {g j i}
lset x {2 1} j => {a b c} {d e f} {g j i}
lset x {2 3} j
.CE
In the following examples, the initial value of \fIx\fP is:
.CS


{{a b} {c d}} {{e f} {g h}}
.CE
The indicated return value also becomes the new value of \fIx\fP.
.CS
lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}}
lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lsort(n), lrange(n), lreplace(n)

.SH KEYWORDS
element, index, list, replace, set
.VE







>
|















>
>
|












<
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110

than or equal to zero.  The integer appearing in each \fIindex\fR
argument must be strictly less than the length of the corresponding
list.  In other words, the \fBlset\fR command cannot change the size
of a list.  If an index is outside the permitted range, an error is reported.
.SH EXAMPLES
In each of these examples, the initial value of \fIx\fP is:
.CS
set x [list [list a b c] [list d e f] [list g h i]]
  => {a b c} {d e f} {g h i}
.CE
The indicated return value also becomes the new value of \fIx\fP.
.CS
lset x {j k l} => j k l
lset x {} {j k l} => j k l
lset x 0 j => j {d e f} {g h i}
lset x 2 j => {a b c} {d e f} j
lset x end j => {a b c} {d e f} j
lset x end-1 j => {a b c} j {d e f}
lset x 2 1 j => {a b c} {d e f} {g j i}
lset x {2 1} j => {a b c} {d e f} {g j i}
lset x {2 3} j
.CE
In the following examples, the initial value of \fIx\fP is:
.CS
set x [list [list [list a b] [list c d]] \e
            [list [list e f] [list g h]]]
 => {{a b} {c d}} {{e f} {g h}}
.CE
The indicated return value also becomes the new value of \fIx\fP.
.CS
lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}}
lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), 
lsort(n), lrange(n), lreplace(n)

.SH KEYWORDS
element, index, list, replace, set

Changes to doc/msgcat.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
'\"
'\" Copyright (c) 1998 Mark Harrison.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" SCCS: @(#) msgcat.n
'\" 
.so man.macros
.TH "msgcat" n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require msgcat 1.2\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp









|







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
'\"
'\" Copyright (c) 1998 Mark Harrison.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" SCCS: @(#) msgcat.n
'\" 
.so man.macros
.TH "msgcat" n 1.3 msgcat "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require msgcat 1.3\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
62
63
64
65
66
67
68
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
none is found, it will search in the parent of the current namespace,
and so on until it reaches the global namespace.  If no translation
string exists, \fB::msgcat::mcunknown\fR is called and the string
returned from \fB::msgcat::mcunknown\fR is returned.
.PP
\fB::msgcat::mc\fR is the main function used to localize an
application.  Instead of using an English string directly, an
applicaton can pass the English string through \fB::msgcat::mc\fR and
use the result.  If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
Given several source strings, \fB::msgcat::mcmax\fR returns the length
of the longest translated string.  This is useful when designing
localized GUI's, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?  
This function sets the locale to \fInewLocale\fR.  If \fInewLocale\fR
is omitted, the current locale is returned, otherwise the current locale
is set to \fInewLocale\fR.

The initial locale defaults to the locale specified in
the user's environment.  See \fBLOCALE AND SUBLOCALE SPECIFICATION\fR
below for a description of the locale string format.
.TP
\fB::msgcat::mcpreferences\fR
Returns an ordered list of the locales preferred by
the user, based on the user's language specification.
The list is ordered from most specific to least
preference.  If the user has specified LANG=en_US_funky,



this procedure would return {en_US_funky en_US en}.
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcpreferences\fR.

Each file located is sourced.  The file extension is ``.msg''.




The number of message files which matched the specification
and were loaded is returned.
.TP
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR
in the specified \fIlocale\fR.  If \fItranslate-string\fR is not
specified, \fIsrc-string\fR is used for both.  The function
returns \fItranslate-string\fR.
.TP
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
Sets the translation for multiple source strings in
\fIsrc-trans-list\fR in the specified \fIlocale\fR.

\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fBmcsetcat::mcmset\fR can be significantly
faster than multiple invocations of \fBmsgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale.  The default action is to return
\fIsrc-string\fR.  This procedure can be redefined by the
application, for example to log error messages for each unknown
string.  The \fB::msgcat::mcunknown\fR procedure is invoked at the
same stack context as the call to \fB::msgcat::mc\fR.  The return vaue
of \fB::msgcat::mcunknown\fR is used as the return vaue for the call
to \fB::msgcat::mc\fR.  

.SH "LOCALE AND SUBLOCALE SPECIFICATION"
.PP
The locale is specified by a locale string.

The locale string consists of
a language code, an optional country code, and an optional
system-specific code, each separated by ``_''.  The country and language
codes are specified in standards ISO-639 and ISO-3166.
For example, the locale ``en'' specifies English and
 ``en_US'' specifes  U.S. English.
.PP
The locale defaults to the value in \fBenv(LANG)\fR at the time the












\fBmsgcat\fR package is loaded.  On Windows, if \fBenv(LANG)\fR is not
set, the package will attempt to extract locale information from the
registry.  If it cannot find this information in the registry, or on
non-Windows platforms when \fBenv(LANG)\fR is not defined, the

locale defaults to ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation.  For example, if a user specifies
en_UK_Funky, the locales ``en_UK_Funky'', ``en_UK'', and ``en'' are
searched in order until a matching translation string is found.  If no
translation string is available, then \fB::msgcat::unknown\fR is
called.

.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative







|







|





|
>
|
|






|
>
>
>
|



|
>
|
>
>
>
>
|




|
|
|



|
>


|










|
|


|

|
>




|
|

|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
<
>
|



|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164

165
166
167
168
169
170
171
172
173
174
175
176
177
none is found, it will search in the parent of the current namespace,
and so on until it reaches the global namespace.  If no translation
string exists, \fB::msgcat::mcunknown\fR is called and the string
returned from \fB::msgcat::mcunknown\fR is returned.
.PP
\fB::msgcat::mc\fR is the main function used to localize an
application.  Instead of using an English string directly, an
application can pass the English string through \fB::msgcat::mc\fR and
use the result.  If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
Given several source strings, \fB::msgcat::mcmax\fR returns the length
of the longest translated string.  This is useful when designing
localized GUIs, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?  
This function sets the locale to \fInewLocale\fR.  If \fInewLocale\fR
is omitted, the current locale is returned, otherwise the current locale
is set to \fInewLocale\fR.  msgcat stores and compares the locale in a
case-insensitive manner, and returns locales in lowercase.
The initial locale is determined by the locale specified in
the user's environment.  See \fBLOCALE SPECIFICATION\fR
below for a description of the locale string format.
.TP
\fB::msgcat::mcpreferences\fR
Returns an ordered list of the locales preferred by
the user, based on the user's language specification.
The list is ordered from most specific to least
preference.  The list is derived from the current
locale set in msgcat by \fBmsgcat::mclocale\fR, and
cannot be set independently.  For example, if the
current locale is en_US_funky, then \fBmsgcat::mcpreferences\fR
returns {en_US_funky en_US en}.
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcpreferences\fR
(note that these are all lowercase), extended by the file
extension ``.msg''.  Each matching file is 
read in order, assuming a UTF-8 encoding.  The file contents are
then evaluated as a Tcl script.  This means that non-Latin characters
may be present in the message file either directly in their UTF-8
encoded form, or by use of the backslash-u quoting recognized by Tcl
evaluation.  The number of message files which matched the specification
and were loaded is returned.
.TP
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR
in the specified \fIlocale\fR and the current namespace.  If
\fItranslate-string\fR is not specified, \fIsrc-string\fR is used
for both.  The function returns \fItranslate-string\fR.
.TP
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
Sets the translation for multiple source strings in
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fBmsgcat::mcmset\fR can be significantly
faster than multiple invocations of \fBmsgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale.  The default action is to return
\fIsrc-string\fR.  This procedure can be redefined by the
application, for example to log error messages for each unknown
string.  The \fB::msgcat::mcunknown\fR procedure is invoked at the
same stack context as the call to \fB::msgcat::mc\fR.  The return value
of \fB::msgcat::mcunknown\fR is used as the return value for the call
to \fB::msgcat::mc\fR.  

.SH "LOCALE SPECIFICATION"
.PP
The locale is specified to \fBmsgcat\fR by a locale string
passed to \fB::msgcat::mclocale\fR.
The locale string consists of
a language code, an optional country code, and an optional
system-specific code, each separated by ``_''.  The country and language
codes are specified in standards ISO-639 and ISO-3166.
For example, the locale ``en'' specifies English and ``en_US'' specifies
U.S. English.
.PP
When the msgcat package is first loaded, the locale is initialized
according to the user's environment.  The variables \fBenv(LC_ALL)\fR,
\fBenv(LC_MESSAGES)\fR, and \fBenv(LANG)\fR are examined in order.
The first of them to have a non-empty value is used to determine the
initial locale.  The value is parsed according to the XPG4 pattern
.CS
language[_country][.codeset][@modifier]
.CE
to extract its parts.  The initial locale is then set by calling
\fBmsgcat::mclocale\fR with the argument 
.CS
language[_country][_modifier]
.CE
On Windows, if none of those environment variables is set, msgcat will
attempt to extract locale information from the
registry.  If all these attempts to discover an initial locale

from the user's environment fail, msgcat defaults to an initial
locale of ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation.  For example, if a user specifies
en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', and ``en'' are
searched in order until a matching translation string is found.  If no
translation string is available, then \fB::msgcat::unknown\fR is
called.

.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
.PP
When searching for a translation of a message, the
message catalog will search first the current namespace,
then the parent of the current namespace, and so on until
the global namespace is reached.  This allows child namespaces
to "inherit" messages from their parent namespace.
.PP
For example, executing the code
.CS
mcset en m1 ":: message1"
mcset en m2 ":: message2"
mcset en m3 ":: message3"
namespace eval ::foo {
    mcset en m2 "::foo message2"
    mcset en m3 "::foo message3"







|







196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
.PP
When searching for a translation of a message, the
message catalog will search first the current namespace,
then the parent of the current namespace, and so on until
the global namespace is reached.  This allows child namespaces
to "inherit" messages from their parent namespace.
.PP
For example, executing (in the ``en'' locale) the code 
.CS
mcset en m1 ":: message1"
mcset en m2 ":: message2"
mcset en m3 ":: message3"
namespace eval ::foo {
    mcset en m2 "::foo message2"
    mcset en m3 "::foo message3"
203
204
205
206
207
208
209
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
.SH "LOCATION AND FORMAT OF MESSAGE FILES"
.PP
Message files can be located in any directory, subject
to the following conditions:
.IP [1]
All message files for a package are in the same directory.
.IP [2]
The message file name is a locale specifier followed
by ``.msg''.  For example:
.CS
es.msg    -- spanish
en_UK.msg -- UK English
.CE
.IP [3]
The file contains a series of calls to mcset, setting the
necessary translation strings for the language. For example:



.CS

::msgcat::mcset es "Free Beer!" "Cerveza Gracias!"

.CE

.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
.IP [1]
During package installation, create a subdirectory
\fBmsgs\fR under your package directory.
.IP [2]
Copy your *.msg files into that directory.
.IP [3]
 Add the following command to your package
initialization script:
.CS
# load language files, stored in msgs subdirectory
::msgcat::mcload [file join [file dirname [info script]] msgs]
.CE

.SH "POSTITIONAL CODES FOR FORMAT AND SCAN COMMANDS"
.PP
It is possible that a message string used as an argument
to \fBformat\fR might have positionally dependent parameters that
might need to be repositioned.  For example, it might be
syntactically desirable to rearrange the sentence structure
while translating.
.CS







|
|


|


|
|
>
>
>

>
|
>




















|







226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
.SH "LOCATION AND FORMAT OF MESSAGE FILES"
.PP
Message files can be located in any directory, subject
to the following conditions:
.IP [1]
All message files for a package are in the same directory.
.IP [2]
The message file name is a msgcat locale specifier (all lowercase)
followed by ``.msg''.  For example:
.CS
es.msg    -- spanish
en_gb.msg -- United Kingdom English
.CE
.IP [3]
The file contains a series of calls to \fBmcset\fR and
\fBmcmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.CS
namespace eval ::mypackage {
    ::msgcat::mcset es "Free Beer!" "Cerveza Gracias!"
}
.CE

.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
.IP [1]
During package installation, create a subdirectory
\fBmsgs\fR under your package directory.
.IP [2]
Copy your *.msg files into that directory.
.IP [3]
 Add the following command to your package
initialization script:
.CS
# load language files, stored in msgs subdirectory
::msgcat::mcload [file join [file dirname [info script]] msgs]
.CE

.SH "POSITIONAL CODES FOR FORMAT AND SCAN COMMANDS"
.PP
It is possible that a message string used as an argument
to \fBformat\fR might have positionally dependent parameters that
might need to be repositioned.  For example, it might be
syntactically desirable to rearrange the sentence structure
while translating.
.CS
Changes to doc/open.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: open.n,v 1.12.14.1 2002/02/05 02:21:58 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: open.n,v 1.12.14.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH open n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
open \- Open a file-based or command pipeline channel
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
the PORTABILITY ISSUES section.
.PP
The \fBfconfigure\fR command can be used to query and set additional
configuration options specific to serial ports.
.VE

.SH "PORTABILITY ISSUES"
.sp
.TP
\fBWindows \fR(all versions)
.
Valid values for \fIfileName\fR to open a serial port are of the form
\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4.
This notation only works for serial ports from 1 to 9, if the system
happens to have more than four.  An attempt to open a serial port that







<







142
143
144
145
146
147
148

149
150
151
152
153
154
155
the PORTABILITY ISSUES section.
.PP
The \fBfconfigure\fR command can be used to query and set additional
configuration options specific to serial ports.
.VE

.SH "PORTABILITY ISSUES"

.TP
\fBWindows \fR(all versions)
.
Valid values for \fIfileName\fR to open a serial port are of the form
\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4.
This notation only works for serial ports from 1 to 9, if the system
happens to have more than four.  An attempt to open a serial port that
230
231
232
233
234
235
236
237
238
239
240
241
.LP
See the PORTABILITY ISSUES section of the \fBexec\fR command for additional
information not specific to command pipelines about executing
applications on the various platforms

.SH "SEE ALSO"
file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
puts(n), exec(n), pid(n), fopen(1)

.SH KEYWORDS
access mode, append, create, file, non-blocking, open, permissions,
pipeline, process, serial







|




229
230
231
232
233
234
235
236
237
238
239
240
.LP
See the PORTABILITY ISSUES section of the \fBexec\fR command for additional
information not specific to command pipelines about executing
applications on the various platforms

.SH "SEE ALSO"
file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
puts(n), exec(n), pid(n), fopen(3)

.SH KEYWORDS
access mode, append, create, file, non-blocking, open, permissions,
pipeline, process, serial
Changes to doc/packagens.n.
1
2
3
4
5
6
7
8
9
10
11
12
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: packagens.n,v 1.3 2000/09/07 14:27:50 poenitz Exp $
'\" 
.so man.macros
.TH pkg::create n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
pkg::create \- Construct an appropriate \fBpackage ifneeded\fR




|







1
2
3
4
5
6
7
8
9
10
11
12
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: packagens.n,v 1.3.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH pkg::create n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
pkg::create \- Construct an appropriate \fBpackage ifneeded\fR
42
43
44
45
46
47
48
49
50
51
52
53
54
55
.TP
\fB\-source\fR\0\fIfilespec\fR
This parameter is similar to the \fB\-load\fR parameter, except that it
specifies a Tcl library that must be loaded with the
\fBsource\fR command.  Any number of \fB\-source\fR parameters may be
specified.
.PP
At least one \fB\-load\fR or \fB\-source\fR paramter must be given.

.SH "SEE ALSO"
package(n)

.SH KEYWORDS
auto-load, index, package, version







|






42
43
44
45
46
47
48
49
50
51
52
53
54
55
.TP
\fB\-source\fR\0\fIfilespec\fR
This parameter is similar to the \fB\-load\fR parameter, except that it
specifies a Tcl library that must be loaded with the
\fBsource\fR command.  Any number of \fB\-source\fR parameters may be
specified.
.PP
At least one \fB\-load\fR or \fB\-source\fR parameter must be given.

.SH "SEE ALSO"
package(n)

.SH KEYWORDS
auto-load, index, package, version
Changes to doc/pkgMkIndex.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.12 2001/08/07 02:54:30 hobbs 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






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: pkgMkIndex.n,v 1.12.8.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
pkg_mkIndex \- Build an index for automatic loading of packages
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
these calls are handled by a stub \fBunknown\fP command.
However, if scripts make variable references to other package's
variables in global code, these will cause errors.  That is
also bad coding style.
.PP
If binary files have dependencies on other packages, things
can become tricky because it is not possible to stub out
C-level API's such as \fBTcl_PkgRequire\fP API
when loading a binary file.
For example, suppose the BLT package requires Tk, and expresses
this with a call to \fBTcl_PkgRequire\fP in its \fBBlt_Init\fP routine.
To support this, you must run \fBpkg_mkIndex\fR in an interpreter that
has Tk loaded.  You can achieve this with the
\fB\-load \fIpkgPat\fR option.  If you specify this option,
\fBpkg_mkIndex\fR will load any packages listed by







|







201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
these calls are handled by a stub \fBunknown\fP command.
However, if scripts make variable references to other package's
variables in global code, these will cause errors.  That is
also bad coding style.
.PP
If binary files have dependencies on other packages, things
can become tricky because it is not possible to stub out
C-level APIs such as \fBTcl_PkgRequire\fP API
when loading a binary file.
For example, suppose the BLT package requires Tk, and expresses
this with a call to \fBTcl_PkgRequire\fP in its \fBBlt_Init\fP routine.
To support this, you must run \fBpkg_mkIndex\fR in an interpreter that
has Tk loaded.  You can achieve this with the
\fB\-load \fIpkgPat\fR option.  If you specify this option,
\fBpkg_mkIndex\fR will load any packages listed by
Changes to doc/registry.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: registry.n,v 1.4 1999/04/16 00:46:35 stanton Exp $
'\" 
.so man.macros
.TH registry n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry
.SH SYNOPSIS
.sp
\fBpackage require registry 1.0\fR






|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: registry.n,v 1.4.28.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH registry n 1.0 registry "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry
.SH SYNOPSIS
.sp
\fBpackage require registry 1.0\fR
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
are:
.TP
\fBregistry delete \fIkeyName\fR ?\fIvalueName\fR?
.
If the optional \fIvalueName\fR argument is present, the specified
value under \fIkeyName\fR will be deleted from the registry.  If the
optional \fIvalueName\fR is omitted, the specified key and any subkeys
or values beneath it in the registry heirarchy will be deleted.  If
the key could not be deleted then an error is generated.  If the key
did not exist, the command has no effect.
.TP
\fBregistry get \fIkeyName valueName\fR
.
Returns the data associated with the value \fIvalueName\fR under the key
\fIkeyName\fR.  If either the key or the value does not exist, then an







|







51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
are:
.TP
\fBregistry delete \fIkeyName\fR ?\fIvalueName\fR?
.
If the optional \fIvalueName\fR argument is present, the specified
value under \fIkeyName\fR will be deleted from the registry.  If the
optional \fIvalueName\fR is omitted, the specified key and any subkeys
or values beneath it in the registry hierarchy will be deleted.  If
the key could not be deleted then an error is generated.  If the key
did not exist, the command has no effect.
.TP
\fBregistry get \fIkeyName valueName\fR
.
Returns the data associated with the value \fIvalueName\fR under the key
\fIkeyName\fR.  If either the key or the value does not exist, then an
Changes to doc/resource.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id: resource.n,v 1.6 2000/09/07 14:27:51 poenitz Exp $
'\" 
.so man.macros
.TH resource n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
resource \- Manipulate Macintosh resources





|







1
2
3
4
5
6
7
8
9
10
11
12
13
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id: resource.n,v 1.6.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH resource n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
resource \- Manipulate Macintosh resources
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
If \fB-name\fR is specified the resource will be named
\fIresourceName\fR, otherwise it will have the empty string as the
name.
.TP
\fB\-file\fR \fIresourceRef\fR
If the \fB-file\fR option is specified then the resource will be
written in the file pointed to by \fIresourceRef\fR, otherwise the
most resently open resource will be used.
.TP
\fB\-force\fR
If the target resource already exists, then by default Tcl will not
overwrite it, but raise an error instead.  Use the -force flag to
force overwriting the extant resource.
.RE








|







117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
If \fB-name\fR is specified the resource will be named
\fIresourceName\fR, otherwise it will have the empty string as the
name.
.TP
\fB\-file\fR \fIresourceRef\fR
If the \fB-file\fR option is specified then the resource will be
written in the file pointed to by \fIresourceRef\fR, otherwise the
most recently open resource will be used.
.TP
\fB\-force\fR
If the target resource already exists, then by default Tcl will not
overwrite it, but raise an error instead.  Use the -force flag to
force overwriting the extant resource.
.RE

Changes to doc/safe.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: safe.n,v 1.3 1999/04/16 00:46:36 stanton Exp $
'\" 
.so man.macros
.TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Safe\ Base \- A mechanism for creating and manipulating safe interpreters.






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
'\"
'\" Copyright (c) 1995-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: safe.n,v 1.3.28.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Safe\ Base \- A mechanism for creating and manipulating safe interpreters.
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
The \fBfile\fR alias provides access to a safe subset of the subcommands of
the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR,
\fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR
subcommands. For more details on what these subcommands do see the manual
page for the \fBfile\fR command.
.TP
\fBencoding\fR ?\fIsubCmd args...\fR?
The \fBenconding\fR alias provides access to a safe subset of the
subcommands of the \fBencoding\fR command;  it disallows setting of
the system encoding, but allows all other subcommands including
\fBsystem\fR to check the current encoding.
.TP
\fBexit\fR
The calling interpreter is deleted and its computation is stopped, but the
Tcl process in which this interpreter exists is not terminated.







|







242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
The \fBfile\fR alias provides access to a safe subset of the subcommands of
the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR,
\fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR
subcommands. For more details on what these subcommands do see the manual
page for the \fBfile\fR command.
.TP
\fBencoding\fR ?\fIsubCmd args...\fR?
The \fBencoding\fR alias provides access to a safe subset of the
subcommands of the \fBencoding\fR command;  it disallows setting of
the system encoding, but allows all other subcommands including
\fBsystem\fR to check the current encoding.
.TP
\fBexit\fR
The calling interpreter is deleted and its computation is stopped, but the
Tcl process in which this interpreter exists is not terminated.
Changes to doc/scan.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: scan.n,v 1.7.14.1 2002/06/10 05:33:08 wolfsuit 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








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: scan.n,v 1.7.14.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH scan n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
scan \- Parse string using conversion specifiers in the style of sscanf
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
character between \fIa\fR and \fIb\fR (inclusive) will be excluded
from the set.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
.TP 10
\fBn\fR
No input is consumed from the input string.  Instead, the total number
of chacters scanned from the input string so far is stored in the variable.
.LP
The number of characters read from the input for a conversion is the
largest number that makes sense for that particular conversion (e.g.
as many decimal digits as possible for \fB%d\fR, as 
many octal digits as possible for \fB%o\fR, and so on).
The input field for a given conversion terminates either when a
white-space character is encountered or when the maximum field 







|







173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
character between \fIa\fR and \fIb\fR (inclusive) will be excluded
from the set.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
.TP 10
\fBn\fR
No input is consumed from the input string.  Instead, the total number
of characters scanned from the input string so far is stored in the variable.
.LP
The number of characters read from the input for a conversion is the
largest number that makes sense for that particular conversion (e.g.
as many decimal digits as possible for \fB%d\fR, as 
many octal digits as possible for \fB%o\fR, and so on).
The input field for a given conversion terminates either when a
white-space character is encountered or when the maximum field 
Changes to doc/string.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: string.n,v 1.14.14.1 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH string n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
string \- Manipulate strings
.SH SYNOPSIS
\fBstring \fIoption arg \fR?\fIarg ...?\fR
.BE

.SH DESCRIPTION
.PP
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.VS 8.1
.TP
\fBstring bytelength \fIstring\fR
Returns a decimal string giving the number of bytes used to represent
\fIstring\fR in memory.  Because UTF\-8 uses one to three bytes to
represent Unicode characters, the byte length will not be the same as
the character length in general.  The cases where a script cares about
the byte length are rare.  In almost all cases, you should use the
\fBstring length\fR operation (including determining the length of a
Tcl ByteArray object).  Refer to the \fBTcl_NumUtfChars\fR
manual entry for more details on the UTF\-8 representation.
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR
.VE 8.1
Perform a character-by-character comparison of strings \fIstring1\fR and
\fIstring2\fR.  Returns
\-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically
less than, equal to, or greater than \fIstring2\fR.
.VS 8.1
If \fB\-length\fR is specified, then only the first \fIlength\fR characters
are used in the comparison.  If \fB\-length\fR is negative, it is
ignored.  If \fB\-nocase\fR is specified, then the strings are
compared in a case-insensitive manner.
.TP
\fBstring equal\fR ?\fB\-nocase\fR? ?\fB-length int\fR? \fIstring1 string2\fR
Perform a character-by-character comparison of strings
\fIstring1\fR and \fIstring2\fR.  Returns 1 if \fIstring1\fR and
\fIstring2\fR are identical, or 0 when not.  If \fB\-length\fR is
specified, then only the first \fIlength\fR characters are used in the
comparison.  If \fB\-length\fR is negative, it is ignored.  If
\fB\-nocase\fR is specified, then the strings are compared in a
case-insensitive manner.
.TP
\fBstring first \fIstring1 string2\fR ?\fIstartIndex\fR?
.VE 8.1
Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR.  If found, return the index of the
first character in the first such match within \fIstring2\fR.  If not
found, return \-1.
.VS 8.1
If \fIstartIndex\fR is specified (in any of the forms accepted by the
\fBindex\fR method), then the search is constrained to start with the
character in \fIstring2\fR specified by the index.  For example,
.RS
.CS
\fBstring first a 0a23456789abcdef 5\fR
.CE
will return \fB10\fR, but
.CS
\fBstring first a 0123456789abcdef 11\fR
.CE
will return \fB\-1\fR.
.RE
.VE 8.1
.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.  
.VS 8.1
\fIcharIndex\fR may be specified as
follows:
.RS
.IP \fIinteger\fR 10
The char specified at this integral index
.IP \fBend\fR 10
The last char of the string.
.IP \fBend\-\fIinteger\fR 10
The last char of the string minus the specified integer
offset (e.g. \fBend\-1\fR would refer to the "c" in "abcd").
.PP
.VE 8.1
If \fIcharIndex\fR is less than 0 or greater than
or equal to the length of the string then an empty string is
returned.
.VS 8.1
.RE
.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
Returns 1 if \fIstring\fR is a valid member of the specified character
class, otherwise returns 0.  If \fB\-strict\fR is specified, then an
empty string returns 0, otherwise and empty string will return 1 on
any class.  If \fB\-failindex\fR is specified, then if the function
returns 0, the index in the string where the class was no longer valid
will be stored in the variable named \fIvarname\fR.  The \fIvarname\fR
will not be set if the function returns 1.  The following character classes
are recognized (the class name can be abbreviated):
.RS
.IP \fBalnum\fR 10
Any Unicode alphabet or digit character.
.IP \fBalpha\fR 10
Any Unicode alphabet character.
.IP \fBascii\fR 10
Any character with a value less than \\u0080 (those that
are in the 7\-bit ascii range).
.IP \fBboolean\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 10
Any Unicode control character.
.IP \fBdigit\fR 10
Any Unicode digit character.  Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 10
Any of the valid forms for a double in Tcl, with optional surrounding
whitespace.  In case of under/overflow in the value, 0 is returned
and the \fIvarname\fR will contain \-1.
.IP \fBfalse\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false.

.IP \fBgraph\fR 10
Any Unicode printing character, except space.
.IP \fBinteger\fR 10
Any of the valid forms for an integer in Tcl, with optional surrounding
whitespace.  In case of under/overflow in the value, 0 is returned
and the \fIvarname\fR will contain \-1.
.IP \fBlower\fR 10
Any Unicode lower case alphabet character.
.IP \fBprint\fR 10
Any Unicode printing character, including space.
.IP \fBpunct\fR 10
Any Unicode punctuation character.
.IP \fBspace\fR 10
Any Unicode space character.
.IP \fBtrue\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true.

.IP \fBupper\fR 10
Any upper case alphabet character in the Unicode character set.
.IP \fBwordchar\fR 10
Any Unicode word character.  That is any alphanumeric character,
and any Unicode connector punctuation characters (e.g. underscore).
.IP \fBxdigit\fR 10
Any hexadecimal digit character ([0\-9A\-Fa\-f]).
.PP
In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the
function will return 0, then the \fIvarname\fR will always be set to 0,
due to the varied nature of a valid boolean value.
.RE
.TP
\fBstring last \fIstring1 string2\fR ?\fIstartIndex\fR?
.VE 8.1
Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR.  If found, return the index of the
first character in the last such match within \fIstring2\fR.  If there
is no match, then return \-1.
.VS 8.1
If \fIstartIndex\fR is specified (in any of the forms accepted by the
\fBindex\fR method), then only the characters in \fIstring2\fR at or before the
specified \fIstartIndex\fR will be considered by the search.  For example,
.RS
.CS
\fBstring last a 0a23456789abcdef 15\fR
.CE
will return \fB10\fR, but
.CS
\fBstring last a 0a23456789abcdef 9\fR
.CE
will return \fB1\fR.
.RE
.VE 8.1
.TP
\fBstring length \fIstring\fR
Returns a decimal string giving the number of characters in
\fIstring\fR.  Note that this is not necessarily the same as the
number of bytes used to store the string.  If the object is a
ByteArray object (such as those returned from reading a binary
encoded channel), then this will return the actual byte length
of the object.
.VS 8.1
.TP
\fBstring map\fR ?\fB\-nocase\fR? \fIcharMap string\fR
Replaces characters in \fIstring\fR based on the key-value pairs in
\fIcharMap\fR.  \fIcharMap\fR is a list of \fIkey value key value\fR ...
as in the form returned by \fBarray get\fR.  Each instance of a
key in the string will be replaced with its corresponding value.  If
\fB\-nocase\fR is specified, then matching is done without regard to
case differences. Both \fIkey\fR and \fIvalue\fR may be multiple
characters.  Replacement is done in an ordered manner, so the key appearing
first in the list will be checked first, and so on.  \fIstring\fR is
only iterated over once, so earlier key replacements will have no
affect for later key matches.  For example,
.RS
.CS
\fBstring map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc\fR
.CE
will return the string \fB01321221\fR.
.RE
.TP
\fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR
.VE 8.1
See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0
if it doesn't.  
.VS 8.1
If \fB\-nocase\fR is specified, then the pattern attempts to match
against the string in a case insensitive manner.
.VE 8.1
For the two strings to match, their contents
must be identical except that the following special sequences
may appear in \fIpattern\fR:
.RS
.IP \fB*\fR 10
Matches any sequence of characters in \fIstring\fR,
including a null string.
.IP \fB?\fR 10
Matches any single character in \fIstring\fR.
.IP \fB[\fIchars\fB]\fR 10
Matches any character in the set given by \fIchars\fR.  If a sequence
of the form
\fIx\fB\-\fIy\fR appears in \fIchars\fR, then any character
between \fIx\fR and \fIy\fR, inclusive, will match.
.VS 8.1
When used with \fB\-nocase\fR, the end points of the range are converted
to lower case first.  Whereas {[A\-z]} matches '_' when matching
case-sensitively ('_' falls between the 'Z' and 'a'), with \fB\-nocase\fR
this is considered like {[A\-Za\-z]} (and probably what was meant in the
first place).
.VE 8.1
.IP \fB\e\fIx\fR 10
Matches the single character \fIx\fR.  This provides a way of
avoiding the special interpretation of the characters
\fB*?[]\e\fR in \fIpattern\fR.
.RE
.TP
\fBstring range \fIstring first last\fR
Returns a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR. An index of 0 refers to the
.VS 8.1
first character of the string.  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.VE 8.1
If \fIfirst\fR is less than zero then it is treated as if it were zero, and
if \fIlast\fR is greater than or equal to the length of the string then
it is treated as if it were \fBend\fR.  If \fIfirst\fR is greater than
\fIlast\fR then an empty string is returned.
.VS 8.1
.TP
\fBstring repeat \fIstring count\fR
Returns \fIstring\fR repeated \fIcount\fR number of times.
.TP
\fBstring replace \fIstring first last\fR ?\fInewstring\fR?
Removes a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR.  An index of 0 refers to the
first character of the string.  \fIFirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.  If \fInewstring\fR is
specified, then it is placed in the removed character range.
If \fIfirst\fR is less than zero then it is treated as if it were zero, and
if \fIlast\fR is greater than or equal to the length of the string then
it is treated as if it were \fBend\fR.  If \fIfirst\fR is greater than
\fIlast\fR or the length of the initial string, or \fIlast\fR is less
than 0, then the initial string is returned untouched.
.TP
\fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all upper (or title) case
letters have been converted to lower case.  If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying.  If
\fIlast\fR is specified, it refers to the char index in the string to stop
at (inclusive).  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that the first character
in \fIstring\fR is converted to its Unicode title case variant (or upper
case if there is no title case variant) and the rest of the string is
converted to lower case.  If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying.  If
\fIlast\fR is specified, it refers to the char index in the string to stop
at (inclusive).  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all lower (or title) case
letters have been converted to upper case.  If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying.  If
\fIlast\fR is specified, it refers to the char index in the string to stop
at (inclusive).  \fIfirst\fR and \fIlast\fR may be specified as for the
\fBindex\fR method.
.VE 8.1
.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading
or trailing characters from the set given by \fIchars\fR are
removed.
If \fIchars\fR is not specified then white space is removed
(spaces, tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any
leading characters from the set given by \fIchars\fR are
removed.
If \fIchars\fR is not specified then white space is removed
(spaces, tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any
trailing characters from the set given by \fIchars\fR are
removed.
If \fIchars\fR is not specified then white space is removed
(spaces, tabs, newlines, and carriage returns).
.VS 8.1
.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR
may be specified as for the \fBindex\fR method.  A word is
considered to be any contiguous range of alphanumeric (Unicode letters
or decimal digits) or underscore (Unicode connector punctuation)
characters, or any single character other than these.
.TP
\fBstring wordstart \fIstring charIndex\fR
Returns the index of the first character in the word containing
character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR may be
specified as for the \fBindex\fR method.  A word is considered to be any
contiguous range of alphanumeric (Unicode letters or decimal digits)
or underscore (Unicode connector punctuation) characters, or any
single character other than these.
.VE 8.1

.SH "SEE ALSO"
expr(n), list(n)

.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype







|















<








|
|


<
|
|
|
<
<
|
|
|
|


|
|
|
|
|
|
<


<



|
<
|
|
|










<


|
|
<
<
|
<


|



|
|

<
|
|
<
<









|
|






|
|









|
|

|
>



|
|
|









|
>



|
|




|
|


|
<



|
<
|
|
|










<





|
|
<
<



|




|
|
|
|








<
|
<
<
|
|
<
|
<
|


|
|




<
|
|
<
|
|
|
|
|
<

|
|
|





|
<
|
|
<
|
|
|
|
<










|
|
|
|
|
|


|
|
|
|
|




|
|
|

|
|
|


|
|
|
|
|
|
<


|
|
<
|
|


|
|
<
|
|


|
|
<
|
|
<
















<






1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32
33
34
35

36
37
38


39
40
41
42
43
44
45
46
47
48
49
50

51
52

53
54
55
56

57
58
59
60
61
62
63
64
65
66
67
68
69

70
71
72
73


74

75
76
77
78
79
80
81
82
83

84
85


86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149

150
151
152
153

154
155
156
157
158
159
160
161
162
163
164
165
166

167
168
169
170
171
172
173


174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

194


195
196

197

198
199
200
201
202
203
204
205
206

207
208

209
210
211
212
213

214
215
216
217
218
219
220
221
222
223

224
225

226
227
228
229

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271

272
273
274
275

276
277
278
279
280
281

282
283
284
285
286
287

288
289

290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305

306
307
308
309
310
311
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: string.n,v 1.14.14.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH string n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
string \- Manipulate strings
.SH SYNOPSIS
\fBstring \fIoption arg \fR?\fIarg ...?\fR
.BE

.SH DESCRIPTION
.PP
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:

.TP
\fBstring bytelength \fIstring\fR
Returns a decimal string giving the number of bytes used to represent
\fIstring\fR in memory.  Because UTF\-8 uses one to three bytes to
represent Unicode characters, the byte length will not be the same as
the character length in general.  The cases where a script cares about
the byte length are rare.  In almost all cases, you should use the
\fBstring length\fR operation (including determining the length of a
Tcl ByteArray object).  Refer to the \fBTcl_NumUtfChars\fR manual
entry for more details on the UTF\-8 representation.
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR

Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR.  Returns \-1, 0, or 1, depending on whether
\fIstring1\fR is lexicographically less than, equal to, or greater


than \fIstring2\fR.  If \fB\-length\fR is specified, then only the
first \fIlength\fR characters are used in the comparison.  If
\fB\-length\fR is negative, it is ignored.  If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring equal\fR ?\fB\-nocase\fR? ?\fB-length int\fR? \fIstring1 string2\fR
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR.  Returns 1 if \fIstring1\fR and \fIstring2\fR are
identical, or 0 when not.  If \fB\-length\fR is specified, then only
the first \fIlength\fR characters are used in the comparison.  If
\fB\-length\fR is negative, it is ignored.  If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.

.TP
\fBstring first \fIstring1 string2\fR ?\fIstartIndex\fR?

Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR.  If found, return the index of the
first character in the first such match within \fIstring2\fR.  If not
found, return \-1.  If \fIstartIndex\fR is specified (in any of the

forms accepted by the \fBindex\fR method), then the search is
constrained to start with the character in \fIstring2\fR specified by
the index.  For example,
.RS
.CS
\fBstring first a 0a23456789abcdef 5\fR
.CE
will return \fB10\fR, but
.CS
\fBstring first a 0123456789abcdef 11\fR
.CE
will return \fB\-1\fR.
.RE

.TP
\fBstring index \fIstring charIndex\fR
Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument.
A \fIcharIndex\fR of 0 corresponds to the first character of the


string.  \fIcharIndex\fR may be specified as follows:

.RS
.IP \fIinteger\fR 10
The char specified at this integral index.
.IP \fBend\fR 10
The last char of the string.
.IP \fBend\-\fIinteger\fR 10
The last char of the string minus the specified integer offset
(e.g. \fBend\-1\fR would refer to the "c" in "abcd").
.PP

If \fIcharIndex\fR is less than 0 or greater than or equal to the
length of the string then an empty string is returned.


.RE
.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
Returns 1 if \fIstring\fR is a valid member of the specified character
class, otherwise returns 0.  If \fB\-strict\fR is specified, then an
empty string returns 0, otherwise and empty string will return 1 on
any class.  If \fB\-failindex\fR is specified, then if the function
returns 0, the index in the string where the class was no longer valid
will be stored in the variable named \fIvarname\fR.  The \fIvarname\fR
will not be set if the function returns 1.  The following character
classes are recognized (the class name can be abbreviated):
.RS
.IP \fBalnum\fR 10
Any Unicode alphabet or digit character.
.IP \fBalpha\fR 10
Any Unicode alphabet character.
.IP \fBascii\fR 10
Any character with a value less than \\u0080 (those that are in the
7\-bit ascii range).
.IP \fBboolean\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 10
Any Unicode control character.
.IP \fBdigit\fR 10
Any Unicode digit character.  Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 10
Any of the valid forms for a double in Tcl, with optional surrounding
whitespace.  In case of under/overflow in the value, 0 is returned and
the \fIvarname\fR will contain \-1.
.IP \fBfalse\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
.IP \fBgraph\fR 10
Any Unicode printing character, except space.
.IP \fBinteger\fR 10
Any of the valid forms for an integer in Tcl, with optional
surrounding whitespace.  In case of under/overflow in the value, 0 is
returned and the \fIvarname\fR will contain \-1.
.IP \fBlower\fR 10
Any Unicode lower case alphabet character.
.IP \fBprint\fR 10
Any Unicode printing character, including space.
.IP \fBpunct\fR 10
Any Unicode punctuation character.
.IP \fBspace\fR 10
Any Unicode space character.
.IP \fBtrue\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
true.
.IP \fBupper\fR 10
Any upper case alphabet character in the Unicode character set.
.IP \fBwordchar\fR 10
Any Unicode word character.  That is any alphanumeric character, and
any Unicode connector punctuation characters (e.g. underscore).
.IP \fBxdigit\fR 10
Any hexadecimal digit character ([0\-9A\-Fa\-f]).
.PP
In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the
function will return 0, then the \fIvarname\fR will always be set to
0, due to the varied nature of a valid boolean value.
.RE
.TP
\fBstring last \fIstring1 string2\fR ?\fIlastIndex\fR?

Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR.  If found, return the index of the
first character in the last such match within \fIstring2\fR.  If there
is no match, then return \-1.  If \fIlastIndex\fR is specified (in any

of the forms accepted by the \fBindex\fR method), then only the
characters in \fIstring2\fR at or before the specified \fIlastIndex\fR
will be considered by the search.  For example,
.RS
.CS
\fBstring last a 0a23456789abcdef 15\fR
.CE
will return \fB10\fR, but
.CS
\fBstring last a 0a23456789abcdef 9\fR
.CE
will return \fB1\fR.
.RE

.TP
\fBstring length \fIstring\fR
Returns a decimal string giving the number of characters in
\fIstring\fR.  Note that this is not necessarily the same as the
number of bytes used to store the string.  If the object is a
ByteArray object (such as those returned from reading a binary encoded
channel), then this will return the actual byte length of the object.


.TP
\fBstring map\fR ?\fB\-nocase\fR? \fIcharMap string\fR
Replaces characters in \fIstring\fR based on the key-value pairs in
\fIcharMap\fR.  \fIcharMap\fR is a list of \fIkey value key value ...\fR
as in the form returned by \fBarray get\fR.  Each instance of a
key in the string will be replaced with its corresponding value.  If
\fB\-nocase\fR is specified, then matching is done without regard to
case differences. Both \fIkey\fR and \fIvalue\fR may be multiple
characters.  Replacement is done in an ordered manner, so the key
appearing first in the list will be checked first, and so on.
\fIstring\fR is only iterated over once, so earlier key replacements
will have no affect for later key matches.  For example,
.RS
.CS
\fBstring map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc\fR
.CE
will return the string \fB01321221\fR.
.RE
.TP
\fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR

See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if


it doesn't.  If \fB\-nocase\fR is specified, then the pattern attempts
to match against the string in a case insensitive manner.  For the two

strings to match, their contents must be identical except that the

following special sequences may appear in \fIpattern\fR:
.RS
.IP \fB*\fR 10
Matches any sequence of characters in \fIstring\fR, including a null
string.
.IP \fB?\fR 10
Matches any single character in \fIstring\fR.
.IP \fB[\fIchars\fB]\fR 10
Matches any character in the set given by \fIchars\fR.  If a sequence

of the form \fIx\fB\-\fIy\fR appears in \fIchars\fR, then any
character between \fIx\fR and \fIy\fR, inclusive, will match.  When

used with \fB\-nocase\fR, the end points of the range are converted to
lower case first.  Whereas {[A\-z]} matches '_' when matching
case-sensitively ('_' falls between the 'Z' and 'a'), with
\fB\-nocase\fR this is considered like {[A\-Za\-z]} (and probably what
was meant in the first place).

.IP \fB\e\fIx\fR 10
Matches the single character \fIx\fR.  This provides a way of avoiding
the special interpretation of the characters \fB*?[]\e\fR in
\fIpattern\fR.
.RE
.TP
\fBstring range \fIstring first last\fR
Returns a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR. An index of 0 refers to the first

character of the string.  \fIfirst\fR and \fIlast\fR may be specified
as for the \fBindex\fR method.  If \fIfirst\fR is less than zero then

it is treated as if it were zero, and if \fIlast\fR is greater than or
equal to the length of the string then it is treated as if it were
\fBend\fR.  If \fIfirst\fR is greater than \fIlast\fR then an empty
string is returned.

.TP
\fBstring repeat \fIstring count\fR
Returns \fIstring\fR repeated \fIcount\fR number of times.
.TP
\fBstring replace \fIstring first last\fR ?\fInewstring\fR?
Removes a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR.  An index of 0 refers to the
first character of the string.  \fIFirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.  If \fInewstring\fR is
specified, then it is placed in the removed character range.  If
\fIfirst\fR is less than zero then it is treated as if it were zero,
and if \fIlast\fR is greater than or equal to the length of the string
then it is treated as if it were \fBend\fR.  If \fIfirst\fR is greater
than \fIlast\fR or the length of the initial string, or \fIlast\fR is
less than 0, then the initial string is returned untouched.
.TP
\fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all upper (or title)
case letters have been converted to lower case.  If \fIfirst\fR is
specified, it refers to the first char index in the string to start
modifying.  If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive).  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that the first character
in \fIstring\fR is converted to its Unicode title case variant (or
upper case if there is no title case variant) and the rest of the
string is converted to lower case.  If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying.  If
\fIlast\fR is specified, it refers to the char index in the string to
stop at (inclusive).  \fIfirst\fR and \fIlast\fR may be specified as
for the \fBindex\fR method.
.TP
\fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all lower (or title)
case letters have been converted to upper case.  If \fIfirst\fR is
specified, it refers to the first char index in the string to start
modifying.  If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive).  \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.

.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading or
trailing characters from the set given by \fIchars\fR are removed.  If

\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading
characters from the set given by \fIchars\fR are removed.  If

\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any trailing
characters from the set given by \fIchars\fR are removed.  If

\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).

.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one in the word
containing character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR
may be specified as for the \fBindex\fR method.  A word is
considered to be any contiguous range of alphanumeric (Unicode letters
or decimal digits) or underscore (Unicode connector punctuation)
characters, or any single character other than these.
.TP
\fBstring wordstart \fIstring charIndex\fR
Returns the index of the first character in the word containing
character \fIcharIndex\fR of \fIstring\fR.  \fIcharIndex\fR may be
specified as for the \fBindex\fR method.  A word is considered to be any
contiguous range of alphanumeric (Unicode letters or decimal digits)
or underscore (Unicode connector punctuation) characters, or any
single character other than these.


.SH "SEE ALSO"
expr(n), list(n)

.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype
Changes to doc/tclsh.1.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tclsh.1,v 1.5.6.1 2002/02/05 02:21:58 wolfsuit Exp $
'\" 
.so man.macros
.TH tclsh 1 "" Tcl "Tcl Applications"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tclsh \- Simple shell containing Tcl interpreter







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tclsh.1,v 1.5.6.2 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH tclsh 1 "" Tcl "Tcl Applications"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tclsh \- Simple shell containing Tcl interpreter
124
125
126
127
128
129
130
131
132
133
134
incomplete commands.

.SH "STANDARD CHANNELS"
.PP
See \fBTcl_StandardChannels\fR for more explanations.

.SH "SEE ALSO"
fconfigure(1), tclvars(1)

.SH KEYWORDS
argument, interpreter, prompt, script file, shell







|



124
125
126
127
128
129
130
131
132
133
134
incomplete commands.

.SH "STANDARD CHANNELS"
.PP
See \fBTcl_StandardChannels\fR for more explanations.

.SH "SEE ALSO"
fconfigure(n), tclvars(n)

.SH KEYWORDS
argument, interpreter, prompt, script file, shell
Changes to doc/tcltest.n.
1
2
3
4
5

6
7
8
9
10
11
12
13
14
15
16
17
18

19
20
21
22
23
24






25
26
27
28









29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
'\"
'\" Copyright (c) 1990-1994 The Regents of the University of California
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 2000 Ajuba Solutions

'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tcltest.n,v 1.11.14.2 2002/06/10 05:33:08 wolfsuit Exp $
'\" 
.so man.macros
.TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tcltest \- Test harness support code and utilities
.SH SYNOPSIS

\fBpackage require tcltest ?2.1?\fR
.sp
\fBtcltest::test \fIname desc ?option value? ?option value? ...\fR
.br
\fBtcltest::test \fIname desc {?option value? ?option value? ...}\fR
.sp






\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR
.sp
\fBtcltest::runAllTests\fR
.sp









\fBtcltest::interpreter \fI?interp?\fR
.sp
\fBtcltest::singleProcess \fI?value?\fR
.sp
\fBtcltest::debug \fI?level?\fR
.sp
\fBtcltest::verbose \fI?levelList?\fR
.sp
\fBtcltest::preserveCore \fI?level?\fR
.sp
\fBtcltest::customMatch \fImode command\fR
.sp
\fBtcltest::testConstraint \fIconstraint ?value?\fR
.sp
\fBtcltest::limitConstraints \fI?value?\fR
.sp
\fBtcltest::workingDirectory \fI?dir?\fR
.sp
\fBtcltest::temporaryDirectory \fI?dir?\fR
.sp
\fBtcltest::testsDirectory \fI?dir?\fR
.sp
\fBtcltest::match \fI?patternList?\fR
.sp
\fBtcltest::matchFiles \fI?patternList?\fR
.sp
\fBtcltest::matchDirectories \fI?patternList?\fR
.sp
\fBtcltest::skip \fI?patternList?\fR
.sp

\fBtcltest::skipFiles \fI?patternList?\fR
.sp
\fBtcltest::skipDirectories \fI?patternList?\fR
.sp
\fBtcltest::loadTestedCommands\fR
.sp
\fBtcltest::loadScript \fI?script?\fR
.sp
\fBtcltest::loadFile \fI?filename?\fR
.sp
\fBtcltest::outputChannel \fI?channelID?\fR
.sp
\fBtcltest::outputFile \fI?filename?\fR
.sp
\fBtcltest::errorChannel \fI?channelID?\fR
.sp
\fBtcltest::errorFile \fI?filename?\fR
.sp
\fBtcltest::makeFile \fIcontents name ?directory?\fR
.sp
\fBtcltest::removeFile \fIname ?directory?\fR
.sp
\fBtcltest::makeDirectory \fIname ?directory?\fR
.sp
\fBtcltest::removeDirectory \fIname ?directory?\fR
.sp
\fBtcltest::viewFile \fIname ?directory?\fR
.sp
\fBtcltest::normalizeMsg \fImsg\fR
.sp
\fBtcltest::normalizePath \fIpathVar\fR

.sp
\fBtcltest::bytestring \fIstring\fR
.BE
.SH DESCRIPTION
.PP
The \fBtcltest\fR package provides the user with utility tools for


writing and running tests in the Tcl test suite.  It can also be used
to create a customized test harness for an extension. 
.PP
The Tcl test suite consists of multiple .test files, each of which
contains multiple test cases.  Each test case consists of a call to
the test command, which specifies the name of  test, a short
description, any constraints that apply to the test case, the script
to be run, and expected results.  See the \fI"Tests"\fR section for more
details. 
.PP
It is also possible to add to this test harness to create your own





customized test harness implementation.  For more defails, see the


section \fI"How to Customize the Test Harness"\fR.

.SH COMMANDS
.TP
\fBtcltest::test\fR \fIname desc ?option value? ?option value? ...\fR
.TP
\fBtcltest::test\fR \fIname desc {?option value? ?option value? ...}\fR


The \fBtcltest::test\fR command runs the value supplied for attribute

\fIscript\fR and compares its result to possible results.  
It prints an error message if actual results and expected results do

not match, or if an error occurs during evaluation of the \fIscript\fR.

The \fBtcltest::test\fR command returns an empty string.  See the
\fI"Tests"\fR section for more details on this command.   
.TP
\fBtcltest::cleanupTests\fR \fI?calledFromAllFile?\fR
This command should be called at the end of a test file.  It prints
statistics about the tests run and removes files that were created by
\fBtcltest::makeDirectory\fR and \fBtcltest::makeFile\fR.  Names
of files and directories created outside of 
\fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR and
never deleted are printed to \fBtcltest::outputChannel\fR.  This command
also restores the original shell environment, as described by the ::env
array. \fIcalledFromAllFile\fR should be specified as a true value if
\fBtcltest::cleanupTests\fR is called explicitly from an "all.tcl"
file.  Tcl files are generally used to run multiple tests.  The






\fBtcltest::cleanupTests\fR command returns an empty string.  For
more details on how to run multiple tests, please see the section
\fI"Running test files"\fR.  
.TP
\fBtcltest::runAllTests\fR
This command should be used in your 'all.tcl' file.  It is used to


loop over test files and directories, determining which test files to
run and then running them.  Note that this test calls
tcltest::cleanupTests; if using this proc in your 'all.tcl' file, you
should not call tcltest::cleanupTests explicitly in that file. See the


sample 'all.tcl' file in the \fI"Examples"\fR section.





.TP
\fBtcltest::interpreter\fR \fI?executableName?\fR
Sets or returns the name of the executable used to invoke the test
suite. This is the interpreter used in runAllTests to run test files

if singleProcess is set to false.  The default value for interpreter
is the name of the interpreter in which the tests were started.  


.TP
\fBtcltest::singleProcess\fR \fI?value?\fR
Sets or returns a boolean indicating whether test files should be sourced
into the current interpreter by runAllTests or run in their own
processes. If \fIvalue\fR is true (1), tests are sourced into the
current interpreter.  If \fIvalue\fR is false (0), tests are run in



the interpreter specified in tcltest::interpreter.  The default value
for tcltest::singleProcess is false.



.TP
\fBtcltest::debug\fR \fI?level?\fR
Sets or returns the current debug level. The debug level determines
how much tcltest package debugging information is printed to stdout.


The default debug level is 0. Levels are defined as:
.RS
.IP 0
Do not display any debug information.

.IP 1
Display information regarding whether a test is skipped because it
doesn't match any of the tests that were specified using -match or
tcltest::match (userSpecifiedNonMatch) or matches any of the tests
specified by -skip or tcltest::skip (userSpecifiedSkip).  
.IP 2

Display the flag array parsed by the command line processor, the
contents of the ::env array, and all user-defined variables that exist
in the current namespace as they are used.
.IP 3
Display information regarding what individual procs in the test

harness are doing.
.RE
.TP
\fBtcltest::verbose\fR \fI?levelList?\fR
Sets or returns the current verbosity level.  The default verbosity
level is "body".   See the "Test output" section for a more detailed


explanation of this option. Levels are defined as: 
.RS
.IP body







Display the body of failed tests
.IP pass
Print output when a test passes
.IP skip
Print output when a test is skipped
.IP start
Print output whenever a test starts
.IP error
Print errorInfo and errorCode, if they exist, when a test return code
does not match its expected return code


.RE
.TP
\fBtcltest::preserveCore\fR \fI?level?\fR
Sets or returns the current core preservation level.  This level
determines how stringent checks for core files are.  The default core
preservation level is 0.  Levels are defined as:


.RS



.IP 0

No checking - do not check for core files at the end of each test
command, but do check for them whenever tcltest::cleanupTests is
called from tcltest::runAllTests. 






.IP 1
Check for core files at the end of each test command and whenever
tcltest::cleanupTests is called from tcltest::runAllTests.
.IP 2


Check for core files at the end of all test commands and whenever
tcltest::cleanupTests is called from all.tcl.  Save any core files
produced in tcltest::temporaryDirectory.
.RE
.TP
\fBtcltest::customMatch \fImode script\fR
Registers \fImode\fR as a new legal value of the \fB-match\fR option
to \fItcltest::test\fR.  When the \fB-match \fImode\fR option is
passed to \fItcltest::test\fR, the script \fIscript\fR will be evaluted
to compare the actual result of the test script against the expected result.

To perform the match, the \fIscript\fR is completed with two additional
words, the expected result, and the actual result, and the completed script
is evaluated in the global namespace.
The completed script is expected to return a boolean value indicating
whether or not the results match.  The built-in matching modes of
\fItcltest::test\fR are \fBexact\fR, \fBglob\fR, and \fBregexp\fR.

.TP
\fBtcltest::testConstraint \fIconstraint ?value?\fR
Sets or returns the value associated with the named \fIconstraint\fR.
See the section \fI"Test constraints"\fR for more information.
.TP
\fBtcltest::limitConstraints \fI?value?\fR
Sets or returns a boolean indicating whether testing is being limited
to the list of constraints specified by the \fB-constraints\fR
command line option.  If \fIvalue\fR is true, only those tests
with constraints present in the list specified in the \fB-constraints\fR
command line option.
.TP
\fBtcltest::workingDirectory\fR \fI?directoryName?\fR
Sets or returns the directory in which the test suite is being run.
The default value for workingDirectory is the directory in which the
test suite was launched.

.TP
\fBtcltest::temporaryDirectory\fR \fI?directoryName?\fR
Sets or returns the output directory for temporary files created by


tcltest::makeFile and tcltest::makeDirectory. This defaults to the
directory returned by \fItcltest::workingDirectory\fR.
.TP
\fBtcltest::testsDirectory\fR \fI?directoryName?\fR
Sets or returns the directory where the tests reside.  This defaults


to the directory returned by \fItcltest::workingDirectory\fR
if the script cannot determine where the \fItests\fR directory is
located. This variable should be explicitly set if tests are being run
from an all.tcl file. 

.TP
\fBtcltest::match\fR \fI?globPatternList?\fR
Sets or returns the glob pattern list that determines which tests
should be run.  Only tests which match one of the glob patterns in
\fIglobPatternList\fR are run by the test harness.  The default value
for \fIglobPatternList\fR is '*'.
.TP
\fBtcltest::matchFiles\fR \fI?globPatternList?\fR
Sets or returns the glob pattern list that determines which test files
should be run.  Only test files which match one of the glob patterns in
\fIglobPatternList\fR are run by the test harness.  The default value
for \fIglobPatternList\fR is '*.test'.
.TP
\fBtcltest::matchDirectories\fR \fI?globPatternList?\fR
Sets or returns the glob pattern list that determines which test
subdirectories of the current test directory should be run.  Only test
subdirectories which match one of the glob patterns in 
\fIglobPatternList\fR are run by the test harness.  The default value
for \fIglobPatternList\fR is '*'.
.TP
\fBtcltest::skip\fR \fI?globPatternList?\fR
Sets or returns the glob pattern list that determines which tests (of
those matched by tcltest::match) should be skipped.  The default value
for \fIglobPatternList\fR is {}.
.TP
\fBtcltest::skipFiles\fR \fI?globPatternList?\fR
Sets or returns the glob pattern list that determines which test files

(of those matched by tcltest::matchFiles) should be skipped.  The
default value for \fIglobPatternList\fR is {}.
.TP
\fBtcltest::skipDirectories\fR \fI?globPatternList?\fR


Sets or returns the glob pattern list that determines which test
subdirectories (of those matched by tcltest::matchDirectories) should
be skipped.  The default value for \fIglobPatternList\fR is {}.
.TP

\fBtcltest::loadTestedCommands\fR
This command uses the script specified via the \fI-load\fR or
\fI-loadfile\fR options or the tcltest::loadScript or
tcltest::loadFile procs to load the commands checked by the test suite.
It is allowed to be empty, as the tested commands could have been
compiled into the interpreter running the test suite.
.TP
\fBtcltest::loadScript\fR \fI?script?\fR
Sets or returns the script executed by \fBloadTestedCommands\fR.   

.TP
\fBtcltest::loadFile\fR \fI?filename?\fR
Sets ore returns the file name associated with the script executed
\fBloadTestedCommands\fR.  If setting \fIfilename\fR, this proc will
open the file and call \fItcltest::loadScript\fR with the content.
.TP
\fBtcltest::outputChannel\fR \fI?channelID?\fR
Sets or returns the output file ID.  This defaults to stdout.
Any test that prints test related output should send
that output to \fItcltest::outputChannel\fR rather than letting
that output default to stdout.

.TP
\fBtcltest::outputFile\fR \fI?filename?\fR
Sets or returns the file name corresponding to the output file.  This
defaults to stdout. This proc calls 
outputChannel to set the output file channel.
Any test that prints test related output should send
that output to \fItcltest::outputChannel\fR rather than letting
that output default to stdout.

.TP
\fBtcltest::errorChannel\fR \fI?channelID?\fR
Sets or returns the error file ID.  This defaults to stderr.
Any test that prints error messages should send
that output to \fItcltest::errorChannel\fR rather than printing
directly to stderr.
.TP
\fBtcltest::errorFile\fR \fI?filename?\fR
Sets or returns the file name corresponding to the error file.  This
defaults to stderr. This proc calls
errorChannel to set the error file channel.
Any test that prints test related error output should send



that output to \fItcltest::errorChannel\fR or
\fItcltest::outputChannel\fR rather than letting

that output default to stdout.
.TP
\fBtcltest::makeFile\fR \fIcontents name ?directory?\fR
Create a file that will be automatically be removed by







\fBtcltest::cleanupTests\fR at the end of a test file.  This file is
created relative to \fIdirectory\fR.  If left unspecified,
\fIdirectory\fR defaults to tcltest::temporaryDirectory.
Returns the full path of the file created.
.TP
\fBtcltest::removeFile\fR \fIname ?directory?\fR
Force the file referenced by \fIname\fR to be removed.  This file name
should be relative to \fIdirectory\fR.   If left unspecified,
\fIdirectory\fR defaults to tcltest::temporaryDirectory.  This proc
has no defined return values.
.TP
\fBtcltest::makeDirectory\fR \fIname ?directory?\fR
Create a directory named \fIname\fR that will automatically be removed
by \fBtcltest::cleanupTests\fR at the end of a test file.  This
directory is created relative to tcltest::temporaryDirectory.
Returns the full path of the directory created.


.TP
\fBtcltest::removeDirectory\fR \fIname\fR
Force the directory referenced by \fIname\fR to be removed. This
directory should be relative to \fIdirectory\fR.   If left unspecified,
\fIdirectory\fR defaults to tcltest::temporaryDirectory.  This proc
has no defined return value. 
.TP
\fBtcltest::viewFile\fR \fIfile ?directory?\fR
Returns the contents of \fIfile\fR.  This file name
should be relative to \fIdirectory\fR.   If left unspecified,
\fIdirectory\fR defaults to tcltest::temporaryDirectory.


.TP
\fBtcltest::normalizeMsg\fR \fImsg\fR
Remove extra newlines from \fImsg\fR.




.TP
\fBtcltest::normalizePath\fR \fIpathVar\fR
Resolves symlinks in a path, thus creating a path without internal
redirection.  It is assumed that \fIpathVar\fR is absolute.
\fIpathVar\fR is modified in place.

.TP
\fBtcltest::bytestring\fR \fIstring\fR
Construct a string that consists of the requested sequence of bytes,
as opposed to a string of properly formed UTF-8 characters using the
value supplied in \fIstring\fR.  This allows the tester to create
denormalized or improperly formed strings to pass to C procedures that
are supposed to accept strings with embedded NULL types and confirm
that a string result has a certain pattern of bytes.

.SH TESTS

The \fBtest\fR procedure runs a test script and prints an error

message if the script's result does not match the expected result.
Two syntaxes are provided for specifying the attributes of the tests.
The first uses a separate argument for each of the attributes and
values.  The second form places all of the attributes and values
together into a single argument; the argument must have proper list
structure, with the elements of the list being the attributes and
values.  The second form makes it easy to construct multi-line
scripts, since the braces around the whole list make it unnecessary to
include a backslash at the end of each line.  In the second form, no
command or variable substitutions are performed on the attribute
names.  This makes the behavior of the second form different from the
first form in some cases.

.PP
The first form for the \fBtest\fR command:
.DS

test \fIname\fR \fIdescription\fR
    ?-constraints \fIkeywordList|expression\fR
    ?-setup \fIsetupScript\fR?
    ?-body \fItestScript\fR?
    ?-cleanup \fIcleanupScript\fR?
    ?-result \fIexpectedAnswer\fR?
    ?-output \fIexpectedOutput\fR?
    ?-errorOutput \fIexpectedError\fR?
    ?-returnCodes \fIcodeList\fR?
    ?-match \fImode\fR?
.DE
.PP
The second form for the \fBtest\fR command (adds brace grouping):
.DS
test \fIname\fR \fIdescription\fR {
    ?-constraints \fIkeywordList|expression\fR
    ?-setup \fIsetupScript\fR?
    ?-body \fItestScript\fR?
    ?-cleanup \fIcleanupScript\fR?
    ?-result \fIexpectedAnswer\fR?
    ?-output\fIexpectedOutput\fR?
    ?-errorOutput \fIexpectedError\fR?
    ?-returnCodes \fIcodeList\fR?
    ?-match \fImode\fR?
}
.DE
The \fIname\fR argument should follow the pattern:
.DS
<target>-<majorNum>.<minorNum>
.DE
For white-box (regression) tests, the target should be the name of the
C function or Tcl procedure being tested.  For black-box tests, the
target should be the name of the feature being tested.  Related tests

should share a major number.











.PP
The \fIdescription\fR should be a short textual description of the
test.  It is generally used to help humans 

understand the purpose of the test.  The name of a Tcl or C function
being tested should be included in the description for regression
tests.  If the test case exists to reproduce a bug, include the bug ID
in the description. 
.PP
Valid attributes and associated values are:
.TP
\fB-constraints \fIkeywordList|expression\fR
The optional \fIconstraints\fR attribute can be list of one or more
keywords or an expression.  If the \fIconstraints\fR value consists of
keywords, each of these keywords being the name of a constraint
defined by a call to \fItcltest::testConstraint\fR.  If any of these
elements is false or does 
not exist, the test is skipped.  If the \fIconstraints\fR argument
consists of an expression, that expression is evaluated. If the
expression evaluates to true, then the test is run.  Appropriate



constraints should be added to any tests that should
not always be run.  See the "Test Constraints" section for a list of built-in 






constraints and information on how to add your own constraints.
.TP
\fB-setup \fIscript\fR
The optional \fIsetup\fR attribute indicates a script that will be run
before the script indicated by the \fIscript\fR attribute.  If setup
fails, the test will fail.

.TP
\fB-body \fIscript\fR
The \fIbody\fR attribute indicates the script to run to carry out the 
test.  It must return a result that can be checked for correctness.

If left unspecified, the script value will be {}.
.TP
\fB-cleanup \fIscript\fR
The optional \fIcleanup\fR attribute indicates a script that will be
run after the script indicated by the \fIscript\fR attribute.  If
cleanup fails, the test will fail.  

.TP
\fB-match \fImode\fR
The \fImatch\fR attribute determines how expected answers supplied in
\fIresult\fR, \fIoutput\fR, and \fIerrorOutput\fR are compared.  Valid
options for the value supplied are ``regexp'', ``glob'', ``exact'',

and any value registered by a prior call to \fItcltest::customMatch\fR.
If \fImatch\fR is not specified, the comparisons will be
done in ``exact'' mode by default.
.TP
\fB-result \fIexpectedValue\fR
The \fIresult\fR attribute supplies the comparison value with which
the return value from script will be compared. 
If left unspecified, the default
\fIexpectedValue\fR will be the empty list.
.TP
\fB-output \fIexpectedValue\fR
The \fIoutput\fR attribute supplies the comparison value with which
any output sent to stdout or tcltest::outputChannel during the script
run will be compared.  Note that only output printed using
puts is used for comparison.  If \fIoutput\fR is not specified, output
sent to stdout and tcltest::outputChannel is not processed for comparison.

.TP
\fB-errorOutput \fIexpectedValue\fR
The \fIerrorOutput\fR attribute supplies the comparison value with which
any output sent to stderr or tcltest::errorChannel during the script
run will be compared. Note that only output printed using

puts is used for comparison.  If \fIerrorOutput\fR is not specified, output
sent to stderr and tcltest::errorChannel is not processed for comparison.
.TP
\fB-returnCodes \fIexpectedCodeList\fR
The optional \fIreturnCodes\fR attribute indicates which return codes

from the script supplied with the \fIscript\fR attribute are correct.
Default values for \fIexpectedCodeList\fR are 0 (normal return) and 2
(return exception).  Symbolic values \fInormal\fR (0), \fIerror\fR
(1), \fIreturn\fR (2), \fIbreak\fR (3), and \fIcontinue\fR (4) can be

used in the \fIexpectedCodeList\fR list.
.PP
To pass, a test must successfully execute its setup, script, and
cleanup code.  The return code of the test and its return values must
match expected values, and if specified, output and error data from
the test must match expected output and error values. If all of these
conditions are not met, then the test fails.















.SH "TEST CONSTRAINTS"

Constraints are used to determine whether or not a test should be skipped.
If a test is constrained by ``unixOnly'', then it will only be run if








the value of the constraint is true.  Several




constraints are defined in the \fBtcltest\fR package.  To add 

constraints, you can call \fBtcltest::testConstraint\fR
with the appropriate arguments in your own test file.


.PP
The following is a list of constraints defined in the \fBtcltest\fR package:

.TP
\fIsingleTestInterp\fR
test can only be run if all test files are sourced into a single interpreter
.TP
\fIunix\fR
test can only be run on any UNIX platform
.TP
\fIwin\fR
test can only be run on any Windows platform
.TP
\fInt\fR
test can only be run on any Windows NT platform
.TP
\fI95\fR
test can only be run on any Windows 95 platform
.TP
\fI98\fR
test can only be run on any Windows 98 platform
.TP
\fImac\fR
test can only be run on any Mac platform
.TP
\fIunixOrWin\fR
test can only be run on a UNIX or Windows platform
.TP
\fImacOrWin\fR
test can only be run on a Mac or Windows platform
.TP
\fImacOrUnix\fR
test can only be run on a Mac or UNIX platform
.TP
\fItempNotWin\fR
test can not be run on Windows.  This flag is used to temporarily
disable a test. 
.TP
\fItempNotMac\fR
test can not be run on a Mac.  This flag is used
to temporarily disable a test.
.TP
\fIunixCrash\fR
test crashes if it's run on UNIX.  This flag is used to temporarily
disable a test. 
.TP
\fIwinCrash\fR
test crashes if it's run on Windows.  This flag is used to temporarily
disable a test. 
.TP
\fImacCrash\fR
test crashes if it's run on a Mac.  This flag is used to temporarily
disable a test. 
.TP
\fIemptyTest\fR
test is empty, and so not worth running, but it remains as a
place-holder for a test to be written in the future.  This constraint
always causes tests to be skipped.

.TP
\fIknownBug\fR
test is known to fail and the bug is not yet fixed.  This constraint
always causes tests to be skipped unless the user specifies otherwise.
See the "Introduction" section for more details.
.TP
\fInonPortable\fR
test can only be run in the master Tcl/Tk development environment.
Some tests are inherently non-portable because they depend on things
like word length, file system configuration, window manager, etc.
These tests are only run in the main Tcl development directory where
the configuration is well known.  This constraint always causes tests
to be skipped unless the user specifies otherwise.  
.TP
\fIuserInteraction\fR
test requires interaction from the user.  This constraint always
causes tests to be skipped unless the user specifies otherwise.  

.TP
\fIinteractive\fR
test can only be run in if the interpreter is in interactive mode 
(when the global tcl_interactive variable is set to 1).
.TP
\fInonBlockFiles\fR
test can only be run if platform supports setting files into





>




|


|





>


|
<
|

>
>
>
>
>
>

<


>
>
>
>
>
>
>
>
>


<
<

<
|
<
<
<
<
<
<
<
|
<
|
<
<
<
|
<

<
<
<

<
|
<
>
|
<
|
<
|
<
|
<
|
<
|
<
|
<
<
<
|

<
<
|
<
<
<
<
<
|
<

<

>
|
<



|
>
>
|
|

<
<
|
|
|
|

|
>
>
>
>
>
|
>
>
|
>


|
<
|
>
>
|
>
|
|
>
|
>
|
<

<
<
<
|
|
|
|
|
|
|
|
>
>
>
>
>
>
|
|
|

<
<
>
>
|
|
|
|
>
>
|
>
>
>
>
>

|
<
<
>
|
|
>
>

|
<
<
<
<
>
>
>
|
<
>
>
>

|
<
<
>
>
|
<
|
|
>
|
<
|
|
|
|
>
|
|
<
|
|
>
|
<

|
|
|
>
>
|
|
<
>
>
>
>
>
>
>
|
<
|
|
<
|
|
|
|
|
>
>
|

|
|
<
<
>
>
|
>
>
>
|
>
|
<
<
>
>
>
>
>
>
|
|
|
<
>
>
|
<
<
<

|

|
|
|
>





|
>

|
|
|

|
|
<
|
|
<
<
<
<
|
<
>

|
|
>
>
|
<

|
|
>
>
|
<
<
<
>

|
<
<
<
|

|
|
|
|
|

|
|
|
|
<
|

|
|
<
<

|
|
>
|
|

|
>
>
|
|
<

>
|
<
<
<
<
<

|
<
>

|
|
<
<

|
<
<
<
<
>

|
<
<
<
<
<
<
>

|
<
<
<
|

|
<
<
<
<
>
>
>
|
|
>
|

|
<
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
<
<
|
<
<
<
<
>
>

|
<
<
<
<
<
<
|
<
|
>
>

|
|
>
>
>
>

|


|
>

|





|
>

>
|
>
|
|
<
<
<
|
<
<
<
<
<
|
>

|

>

|
|
|
|
|
|
|
|
|

<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|

|



|
>
|
>
>
>
>
>
>
>
>
>
>
>


|
>
|
|
|
|




|
|
|
|
<
|
|
|
>
>
>
|
|
>
>
>
>
>
>
|


|
|
|
>


|

>
|


|
|
|
>


|
|
<
>
|
<
|


|
|
<
|


|
|
|
|
|
>


|
|
|
>
|
|


|
>
|
|
|
<
>
|

|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>

|
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
|
|
>
>

|
>





|

















|





|










|













|
>



|
|


|


<
|
|


|
|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
40
41
42
43
44
45


46

47







48

49



50

51



52

53

54
55

56

57

58

59

60

61



62
63


64





65

66

67
68
69

70
71
72
73
74
75
76
77
78


79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97

98
99
100
101
102
103
104
105
106
107
108

109



110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127


128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143


144
145
146
147
148
149
150




151
152
153
154

155
156
157
158
159


160
161
162

163
164
165
166

167
168
169
170
171
172
173

174
175
176
177

178
179
180
181
182
183
184
185

186
187
188
189
190
191
192
193

194
195

196
197
198
199
200
201
202
203
204
205
206


207
208
209
210
211
212
213
214
215


216
217
218
219
220
221
222
223
224

225
226
227



228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248

249
250




251

252
253
254
255
256
257
258

259
260
261
262
263
264



265
266
267



268
269
270
271
272
273
274
275
276
277
278
279

280
281
282
283


284
285
286
287
288
289
290
291
292
293
294
295

296
297
298





299
300

301
302
303
304


305
306




307
308
309






310
311
312



313
314
315




316
317
318
319
320
321
322
323
324

325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340


341




342
343
344
345






346

347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377



378





379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395



396











397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432

433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469

470
471

472
473
474
475
476

477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615

616
617
618
619
620
621
622
623
624
625
626
627
628
629
'\"
'\" Copyright (c) 1990-1994 The Regents of the University of California
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\" Copyright (c) 2000 Ajuba Solutions
'\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tcltest.n,v 1.11.14.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH "tcltest" n 2.1 tcltest "Tcl Bundled Packages"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tcltest \- Test harness support code and utilities
.SH SYNOPSIS
.nf
\fBpackage require tcltest ?2.1?\fR
.sp
\fBtcltest::test \fIname description ?option value ...?\fR

\fBtcltest::test \fIname description ?constraints? body result\fR
.sp
\fBtcltest::loadTestedCommands\fR
\fBtcltest::makeDirectory \fIname ?directory?\fR
\fBtcltest::removeDirectory \fIname ?directory?\fR
\fBtcltest::makeFile \fIcontents name ?directory?\fR
\fBtcltest::removeFile \fIname ?directory?\fR
\fBtcltest::viewFile \fIname ?directory?\fR
\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR

\fBtcltest::runAllTests\fR
.sp
.VS 2.1
\fBtcltest::configure\fR
\fBtcltest::configure \fIoption\fR
\fBtcltest::configure \fIoption value ?option value ...?\fR
\fBtcltest::customMatch \fImode command\fR
.VE
\fBtcltest::testConstraint \fIconstraint ?value?\fR
\fBtcltest::outputChannel \fI?channelID?\fR
\fBtcltest::errorChannel \fI?channelID?\fR
\fBtcltest::interpreter \fI?interp?\fR
.sp


\fBtcltest::debug \fI?level?\fR

\fBtcltest::errorFile \fI?filename?\fR







\fBtcltest::limitConstraints \fI?boolean?\fR

\fBtcltest::loadFile \fI?filename?\fR



\fBtcltest::loadScript \fI?script?\fR

\fBtcltest::match \fI?patternList?\fR



\fBtcltest::matchDirectories \fI?patternList?\fR

\fBtcltest::matchFiles \fI?patternList?\fR

\fBtcltest::outputFile \fI?filename?\fR
\fBtcltest::preserveCore \fI?level?\fR

\fBtcltest::singleProcess \fI?boolean?\fR

\fBtcltest::skip \fI?patternList?\fR

\fBtcltest::skipDirectories \fI?patternList?\fR

\fBtcltest::skipFiles \fI?patternList?\fR

\fBtcltest::temporaryDirectory \fI?directory?\fR

\fBtcltest::testsDirectory \fI?directory?\fR



\fBtcltest::verbose \fI?level?\fR
.sp


\fBtcltest::test \fIname description optionList\fR





\fBtcltest::bytestring \fIstring\fR

\fBtcltest::normalizeMsg \fImsg\fR

\fBtcltest::normalizePath \fIpathVar\fR
\fBtcltest::workingDirectory \fI?dir?\fR
.fi

.BE
.SH DESCRIPTION
.PP
The \fBtcltest\fR package provides several utility commands useful
in the construction of test suites for code instrumented to be
run by evaluation of Tcl commands.  Notably the built-in commands
of the Tcl library itself are tested by a test suite using the
tcltest package.
.PP


All the commands provided by the \fBtcltest\fR package are defined
in and exported from the \fB::tcltest\fR namespace, as indicated in
the \fBSYNOPSIS\fR above.  In the following sections, all commands
will be described by their simple names, in the interest of brevity.
.PP
The central command of \fBtcltest\fR is [\fBtest\fR] that defines
and runs a test.  Testing with [\fBtest\fR] involves evaluation
of a Tcl script and comparing the result to an expected result, as
configured and controlled by a number of options.  Several other
commands provided by \fBtcltest\fR govern the configuration of
[\fBtest\fR] and the collection of many [\fBtest\fR] commands into
test suites.
.PP
See \fBCREATING TEST SUITES WITH TCLTEST\fR below for an extended example
of how to use the commands of \fBtcltest\fR to produce test suites
for your Tcl-enabled code.
.SH COMMANDS
.TP
\fBtest\fR \fIname description ?option value ...?\fR

Defines and possibly runs a test with the name \fIname\fR and
description \fIdescription\fR.  The name and description of a test
are used in messages reported by [\fBtest\fR] during the
test, as configured by the options of \fBtcltest\fR.  The
remaining \fIoption value\fR arguments to [\fBtest\fR]
define the test, including the scripts to run, the conditions
under which to run them, the expected result, and the means
by which the expected and actual results should be compared.
See \fBTESTS\fR below for a complete description of the valid
options and how they define a test.  The [\fBtest\fR] command
returns an empty string.  

.TP



\fBtest\fR \fIname description ?constraints? body result\fR
This form of [\fBtest\fR] is provided to support test suites written
for version 1 of the \fBtcltest\fR package, and also a simpler
interface for a common usage.  It is the same as
[\fBtest\fR \fIname description\fB -constraints \fIconstraints\fB -body
\fIbody\fB -result \fIresult\fR].  All other options to [\fBtest\fR]
take their default values.  When \fIconstraints\fR is omitted, this
form of [\fBtest\fR] can be distinguished from the first because
all \fIoption\fRs begin with ``-''.
.TP
\fBloadTestedCommands\fR
Evaluates in the caller's context the script specified by 
[\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR].
Returns the result of that script evaluation, including any error
raised by the script.  Use this command and the related
configuration options to provide the commands to be tested to
the interpreter running the test suite.
.TP


\fBmakeFile\fR \fIcontents name ?directory?\fR
Creates a file named \fIname\fR relative to
directory \fIdirectory\fR and write \fIcontents\fR
to that file using the encoding [\fBencoding system\fR].
If \fIcontents\fR does not end with a newline, a newline
will be appended so that the file named \fIname\fR
does end with a newline.  Because the system encoding is used,
this command is only suitable for making text files.
The file will be removed by the next evaluation
of [\fBcleanupTests\fR], unless it is removed by
[\fBremoveFile\fR] first.  The default value of
\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
Returns the full path of the file created.  Use this command
to create any text file required by a test with contents as needed.
.TP
\fBremoveFile\fR \fIname ?directory?\fR


Forces the file referenced by \fIname\fR to be removed.  This file name
should be relative to \fIdirectory\fR.   The default value of
\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
Returns an empty string.  Use this command to delete files
created by [\fBmakeFile\fR].  
.TP
\fBmakeDirectory\fR \fIname ?directory?\fR




Creates a directory named \fIname\fR relative to directory \fIdirectory\fR.
The directory will be removed by the next evaluation of [\fBcleanupTests\fR],
unless it is removed by [\fBremoveDirectory\fR] first.
The default value of \fIdirectory\fR is the directory

[\fBconfigure -tmpdir\fR].
Returns the full path of the directory created.  Use this command
to create any directories that are required to exist by a test.
.TP
\fBremoveDirectory\fR \fIname ?directory?\fR


Forces the directory referenced by \fIname\fR to be removed. This
directory should be relative to \fIdirectory\fR.
The default value of \fIdirectory\fR is the directory

[\fBconfigure -tmpdir\fR].
Returns an empty string.  Use this command to delete any directories
created by [\fBmakeDirectory\fR].  
.TP

\fBviewFile\fR \fIfile ?directory?\fR
Returns the contents of \fIfile\fR, except for any
final newline, just as [\fBread -nonewline\fR] would return.
This file name should be relative to \fIdirectory\fR.   
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR].  Use this command
as a convenient way to turn the contents of a file generated

by a test into the result of that test for matching against
an expected result.  The contents of the file are read using
the system encoding, so its usefulness is limited to text
files.

.TP
\fBcleanupTests\fR
Intended to clean up and summarize after several tests have been
run.  Typically called once per test file, at the end of the file
after all tests have been completed.  For best effectiveness, be
sure that the [\fBcleanupTests\fR] is evaluated even if an error
occurs earlier in the test file evaluation.  
.sp

Prints statistics about the tests run and removes files that were
created by [\fBmakeDirectory\fR] and [\fBmakeFile\fR] since the
last [\fBcleanupTests\fR].  Names of files and directories 
in the directory [\fBconfigure -tmpdir\fR] created since
the last [\fBcleanupTests\fR], but not created by
[\fBmakeFile\fR] or [\fBmakeDirectory\fR] are printed
to [\fBoutputChannel\fR].  This command also restores the original
shell environment, as described by the ::env

array. Returns an empty string.
.TP

\fBrunAllTests\fR
This is a master command meant to run an entire suite of tests,
spanning multiple files and/or directories, as governed by
the configurable options of \fBtcltest\fR.  See \fBRUNNING ALL TESTS\fR
below for a complete description of the many variations possible
with [\fBrunAllTests\fR].
.SH "CONFIGURATION COMMANDS"
.VS
.TP
\fBconfigure\fR
Returns the list of configurable options supported by \fBtcltest\fR.


See \fBCONFIGURABLE OPTIONS\fR below for the full list of options,
their valid values, and their effect on \fBtcltest\fR operations.
.TP
\fBconfigure \fIoption\fR
Returns the current value of the supported configurable option \fIoption\fR.
Raises an error if \fIoption\fR is not a supported configurable option.
.TP
\fBconfigure \fIoption value ?option value ...?\fR
Sets the value of each configurable option \fIoption\fR to the


corresponding value \fIvalue\fR, in order.  Raises an error if
an \fIoption\fR is not a supported configurable option, or if
\fIvalue\fR is not a valid value for the corresponding \fIoption\fR,
or if a \fIvalue\fR is not provided.  When an error is raised, the
operation of [\fBconfigure\fR] is halted, and subsequent \fIoption value\fR
arguments are not processed.
.sp
If the environment variable \fB::env(TCLTEST_OPTIONS)\fR exists when
the \fBtcltest\fR package is loaded (by [\fBpackage require tcltest\fR])

then its value is taken as a list of arguments to pass to [\fBconfigure\fR].
This allows the default values of the configuration options to be
set by the environment.



.TP
\fBcustomMatch \fImode script\fR
Registers \fImode\fR as a new legal value of the \fB-match\fR option
to [\fBtest\fR].  When the \fB-match \fImode\fR option is
passed to [\fBtest\fR], the script \fIscript\fR will be evaluated
to compare the actual result of evaluating the body of the test
to the expected result.
To perform the match, the \fIscript\fR is completed with two additional
words, the expected result, and the actual result, and the completed script
is evaluated in the global namespace.
The completed script is expected to return a boolean value indicating
whether or not the results match.  The built-in matching modes of
[\fBtest\fR] are \fBexact\fR, \fBglob\fR, and \fBregexp\fR.
.VE
.TP
\fBtestConstraint \fIconstraint ?boolean?\fR
Sets or returns the boolean value associated with the named \fIconstraint\fR.
See \fBTEST CONSTRAINTS\fR below for more information.
.TP
\fBinterpreter\fR \fI?executableName?\fR
Sets or returns the name of the executable to be [\fBexec\fR]ed by

[\fBrunAllTests\fR] to run each test file when
[\fBconfigure -singleproc\fR] is false.




The default value for [\fBinterpreter\fR] is the name of the

currently running program as returned by [\fBinfo nameofexecutable\fR].
.TP
\fBoutputChannel\fR \fI?channelID?\fR
Sets or returns the output channel ID.  This defaults to stdout.
Any test that prints test related output should send
that output to [\fBoutputChannel\fR] rather than letting
that output default to stdout.

.TP
\fBerrorChannel\fR \fI?channelID?\fR
Sets or returns the error channel ID.  This defaults to stderr.
Any test that prints error messages should send
that output to [\fBerrorChannel\fR] rather than printing
directly to stderr.



.SH "SHORTCUT COMMANDS"
.TP
\fBdebug \fI?level?\fR



Same as [\fBconfigure -debug \fI?level?\fR].
.TP
\fBerrorFile \fI?filename?\fR
Same as [\fBconfigure -errfile \fI?filename?\fR].
.TP
\fBlimitConstraints \fI?boolean?\fR
Same as [\fBconfigure -limitconstraints \fI?boolean?\fR].
.TP
\fBloadFile \fI?filename?\fR
Same as [\fBconfigure -loadfile \fI?filename?\fR].
.TP
\fBloadScript \fI?script?\fR

Same as [\fBconfigure -load \fI?script?\fR].
.TP
\fBmatch \fI?patternList?\fR
Same as [\fBconfigure -match \fI?patternList?\fR].


.TP
\fBmatchDirectories \fI?patternList?\fR
Same as [\fBconfigure -relateddir \fI?patternList?\fR].
.TP
\fBmatchFiles \fI?patternList?\fR
Same as [\fBconfigure -file \fI?patternList?\fR].
.TP
\fBoutputFile \fI?filename?\fR
Same as [\fBconfigure -outfile \fI?filename?\fR].
.TP
\fBpreserveCore \fI?level?\fR
Same as [\fBconfigure -preservecore \fI?level?\fR].

.TP
\fBsingleProcess \fI?boolean?\fR
Same as [\fBconfigure -singleproc \fI?boolean?\fR].





.TP
\fBskip \fI?patternList?\fR

Same as [\fBconfigure -skip \fI?patternList?\fR].
.TP
\fBskipDirectories \fI?patternList?\fR
Same as [\fBconfigure -asidefromdir \fI?patternList?\fR].


.TP
\fBskipFiles \fI?patternList?\fR




Same as [\fBconfigure -notfile \fI?patternList?\fR].
.TP
\fBtemporaryDirectory \fI?directory?\fR






Same as [\fBconfigure -tmpdir \fI?directory?\fR].
.TP
\fBtestsDirectory \fI?directory?\fR



Same as [\fBconfigure -testdir \fI?directory?\fR].
.TP
\fBverbose \fI?level?\fR




Same as [\fBconfigure -verbose \fI?level?\fR].
.SH "OTHER COMMANDS"
.PP
The remaining commands provided by \fBtcltest\fR have better
alternatives provided by \fBtcltest\fR or \fBTcl\fR itself.  They
are retained to support existing test suites, but should be avoided
in new code.
.TP
\fBtest\fR \fIname description optionList\fR

This form of [\fBtest\fR] was provided to enable passing many
options spanning several lines to [\fBtest\fR] as a single
argument quoted by braces, rather than needing to backslash quote
the newlines between arguments to [\fBtest\fR].  The \fIoptionList\fR
argument is expected to be a list with an even number of elements
representing \fIoption\fR and \fIvalue\fR arguments to pass
to [\fBtest\fR].  However, these values are not passed directly, as
in the alternate forms of [\fBswitch\fR].  Instead, this form makes
an unfortunate attempt to overthrow Tcl's substitution rules by
performing substitutions on some of the list elements as an attempt to
implement a ``do what I mean'' interpretation of a brace-enclosed
``block''.  The result is nearly impossible to document clearly, and
for that reason this form is not recommended.  See the examples in
\fBCREATING TEST SUITES WITH TCLTEST\fR below to see that this
form is really not necessary to avoid backslash-quoted newlines.
If you insist on using this form, examine


the source code of \fBtcltest\fR if you want to know the substitution




details, or just enclose the third through last argument
to [\fBtest\fR] in braces and hope for the best.
.TP
\fBworkingDirectory\fR \fI?directoryName?\fR






Sets or returns the current working directory when the test suite is

running.  The default value for workingDirectory is the directory in
which the test suite was launched.  The Tcl commands [\fBcd\fR] and
[\fBpwd\fR] are sufficient replacements.
.TP
\fBnormalizeMsg\fR \fImsg\fR
Returns the result of removing the ``extra'' newlines from \fImsg\fR,
where ``extra'' is rather imprecise.  Tcl offers plenty of string
processing commands to modify strings as you wish, and
[\fBcustomMatch\fR] allows flexible matching of actual and expected
results.
.TP
\fBnormalizePath\fR \fIpathVar\fR
Resolves symlinks in a path, thus creating a path without internal
redirection.  It is assumed that \fIpathVar\fR is absolute.
\fIpathVar\fR is modified in place.  The Tcl command [\fBfile normalize\fR]
is a sufficient replacement.
.TP
\fBbytestring\fR \fIstring\fR
Construct a string that consists of the requested sequence of bytes,
as opposed to a string of properly formed UTF-8 characters using the
value supplied in \fIstring\fR.  This allows the tester to create
denormalized or improperly formed strings to pass to C procedures that
are supposed to accept strings with embedded NULL types and confirm
that a string result has a certain pattern of bytes.  This is
exactly equivalent to the Tcl command [\fBencoding convertfrom identity\fR].
.SH TESTS
.PP
The [\fBtest\fR] command is the heart of the \fBtcltest\fR package.
Its essential function is to evaluate a Tcl script and compare
the result with an expected result.  The options of [\fBtest\fR]
define the test script, the environment in which to evaluate it,



the expected result, and how the compare the actual result to





the expected result.  Some configuration options of \fBtcltest\fR
also influence how [\fBtest\fR] operates.
.PP
The valid options for [\fBtest\fR] are summarized:
.DS
.ta 0.8i
test \fIname\fR \fIdescription\fR
	?-constraints \fIkeywordList|expression\fR?
	?-setup \fIsetupScript\fR?
	?-body \fItestScript\fR?
	?-cleanup \fIcleanupScript\fR?
	?-result \fIexpectedAnswer\fR?
	?-output \fIexpectedOutput\fR?
	?-errorOutput \fIexpectedError\fR?
	?-returnCodes \fIcodeList\fR?
	?-match \fImode\fR?
.DE



The \fIname\fR may be any string.  It is conventional to choose











a \fIname\fR according to the pattern:
.DS
\fItarget\fR-\fImajorNum\fR.\fIminorNum\fR
.DE
For white-box (regression) tests, the target should be the name of the
C function or Tcl procedure being tested.  For black-box tests, the
target should be the name of the feature being tested.  Some conventions
call for the names of black-box tests to have the suffix \fB_bb\fR.
Related tests should share a major number.  As a test suite evolves,
it is best to have the same test name continue to correspond to the
same test, so that it remains meaningful to say things like ``Test
foo-1.3 passed in all releases up to 3.4, but began failing in
release 3.5.''
.PP
During evaluation of [\fBtest\fR], the \fIname\fR will be compared
to the lists of string matching patterns returned by
[\fBconfigure -match\fR], and [\fBconfigure -skip\fR].  The test
will be run only if \fIname\fR matches one of the patterns from
[\fBconfigure -match\fR] and matches none of the patterns
from [\fBconfigure -skip\fR].
.PP
The \fIdescription\fR should be a short textual description of the
test.  The \fIdescription\fR is included in output produced by the
test, typically test failure messages.  Good \fIdescription\fR values
should briefly explain the purpose of the test to users of a test suite.
The name of a Tcl or C function being tested should be included in the
description for regression tests.  If the test case exists to reproduce
a bug, include the bug ID in the description. 
.PP
Valid attributes and associated values are:
.TP
\fB-constraints \fIkeywordList|expression\fR
The optional \fB-constraints\fR attribute can be list of one or more
keywords or an expression.  If the \fB-constraints\fR value is a list of
keywords, each of these keywords should be the name of a constraint
defined by a call to [\fBtestConstraint\fR].  If any of the listed

constraints is false or does not exist, the test is skipped.  If the
\fB-constraints\fR value is an expression, that expression
is evaluated. If the expression evaluates to true, then the test is run.
Note that the expression form of \fB-constraints\fR may interfere with the
operation of [\fBconfigure -constraints\fR] and
[\fBconfigure -limitconstraints\fR], and is not recommended.
Appropriate constraints should be added to any tests that should
not always be run.  That is, conditional evaluation of a test
should be accomplished by the \fB-constraints\fR option, not by
conditional evaluation of [\fBtest\fR].  In that way, the same
number of tests are always reported by the test suite, though
the number skipped may change based on the testing environment.
The default value is an empty list.  
See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints 
and information on how to add your own constraints.
.TP
\fB-setup \fIscript\fR
The optional \fB-setup\fR attribute indicates a \fIscript\fR that will be run
before the script indicated by the \fB-body\fR attribute.  If evaluation
of \fIscript\fR raises an error, the test will fail.  The default value
is an empty script.
.TP
\fB-body \fIscript\fR
The \fB-body\fR attribute indicates the \fIscript\fR to run to carry out the 
test.  It must return a result that can be checked for correctness.
If evaluation of \fIscript\fR raises an error, the test will fail.
The default value is an empty script.
.TP
\fB-cleanup \fIscript\fR
The optional \fB-cleanup\fR attribute indicates a \fIscript\fR that will be
run after the script indicated by the \fB-body\fR attribute.
If evaluation of \fIscript\fR raises an error, the test will fail.
The default value is an empty script.
.TP
\fB-match \fImode\fR
The \fB-match\fR attribute determines how expected answers supplied by
\fB-result\fR, \fB-output\fR, and \fB-errorOutput\fR are compared.  Valid

values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and
any value registered by a prior call to [\fBcustomMatch\fR].  The default

value is \fBexact\fR.
.TP
\fB-result \fIexpectedValue\fR
The \fB-result\fR attribute supplies the \fIexpectedValue\fR against which
the return value from script will be compared. The default value is

an empty string.
.TP
\fB-output \fIexpectedValue\fR
The \fB-output\fR attribute supplies the \fIexpectedValue\fR against which
any output sent to \fBstdout\fR or [\fBoutputChannel\fR] during evaluation
of the script(s) will be compared.  Note that only output printed using
[\fBputs\fR] is used for comparison.  If \fB-output\fR is not specified,
output sent to \fBstdout\fR and [\fBoutputChannel\fR] is not processed for
comparison.
.TP
\fB-errorOutput \fIexpectedValue\fR
The \fB-errorOutput\fR attribute supplies the \fIexpectedValue\fR against
which any output sent to \fBstderr\fR or [\fBerrorChannel\fR] during 
evaluation of the script(s) will be compared. Note that only output
printed using [\fBputs\fR] is used for comparison.  If \fB-errorOutput\fR
is not specified, output sent to \fBstderr\fR and [\fBerrorChannel\fR] is
not processed for comparison.
.TP
\fB-returnCodes \fIexpectedCodeList\fR
The optional \fB-returnCodes\fR attribute supplies \fIexpectedCodeList\fR,
a list of return codes that may be accepted from evaluation of the
\fB-body\fR script.  If evaluation of the \fB-body\fR script returns
a code not in the \fIexpectedCodeList\fR, the test fails.  All
return codes known to [\fBreturn\fR], in both numeric and symbolic

form, including extended return codes, are acceptable elements in
the \fIexpectedCodeList\fR.  Default value is \fB{ok return}\fR.
.PP
To pass, a test must successfully evaluate its \fB-setup\fR, \fB-body\fR,
and \fB-cleanup\fR scripts.  The return code of the \fB-body\fR script and
its result must match expected values, and if specified, output and error
data from the test must match expected \fB-output\fR and \fB-errorOutput\fR
values.  If any of these conditions are not met, then the test fails.
Note that all scripts are evaluated in the context of the caller
of [\fBtest\fR].
.PP
As long as [\fBtest\fR] is called with valid syntax and legal
values for all attributes, it will not raise an error.  Test
failures are instead reported as output written to [\fBoutputChannel\fR].
In default operation, a successful test produces no output.  The output
messages produced by [\fBtest\fR] are controlled by the
[\fBconfigure -verbose\fR] option as described in \fBCONFIGURABLE OPTIONS\fR
below.  Any output produced by the test scripts themselves should be
produced using [\fBputs\fR] to [\fBoutputChannel\fR] or
[\fBerrorChannel\fR], so that users of the test suite may
easily capture output with the [\fBconfigure -outfile\fR] and
[\fBconfigure -errfile\fR] options, and so that the \fB-output\fR
and \fB-errorOutput\fR attributes work properly.
.SH "TEST CONSTRAINTS"
.PP
Constraints are used to determine whether or not a test should be skipped.
Each constraint has a name, which may be any string, and a boolean
value.  Each [\fBtest\fR] has a \fB-constraints\fR value which is a
list of constraint names.  There are two modes of constraint control.
Most frequently, the default mode is used, indicated by a setting
of [\fBconfigure -limitconstraints\fR] to false.  The test will run
only if all constraints in the list are true-valued.  Thus,
the \fB-constraints\fR option of [\fBtest\fR] is a convenient, symbolic
way to define any conditions required for the test to be possible or
meaningful.  For example, a [\fBtest\fR] with \fB-constraints unix\fR
will only be run if the constraint \fBunix\fR is true, which indicates
the test suite is being run on a Unix platform.
.PP
Each [\fBtest\fR] should include whatever \fB-constraints\fR are
required to constrain it to run only where appropriate.  Several
constraints are pre-defined in the \fBtcltest\fR package, listed
below.  The registration of user-defined constraints is performed
by the [\fBtestConstraint\fR] command.  User-defined constraints
may appear within a test file, or within the script specified
by the [\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR]
options.
.PP
The following is a list of constraints pre-defined by the
\fBtcltest\fR package itself:
.TP
\fIsingleTestInterp\fR
test can only be run if all test files are sourced into a single interpreter
.TP
\fIunix\fR
test can only be run on any Unix platform
.TP
\fIwin\fR
test can only be run on any Windows platform
.TP
\fInt\fR
test can only be run on any Windows NT platform
.TP
\fI95\fR
test can only be run on any Windows 95 platform
.TP
\fI98\fR
test can only be run on any Windows 98 platform
.TP
\fImac\fR
test can only be run on any Mac platform
.TP
\fIunixOrWin\fR
test can only be run on a Unix or Windows platform
.TP
\fImacOrWin\fR
test can only be run on a Mac or Windows platform
.TP
\fImacOrUnix\fR
test can only be run on a Mac or Unix platform
.TP
\fItempNotWin\fR
test can not be run on Windows.  This flag is used to temporarily
disable a test. 
.TP
\fItempNotMac\fR
test can not be run on a Mac.  This flag is used
to temporarily disable a test.
.TP
\fIunixCrash\fR
test crashes if it's run on Unix.  This flag is used to temporarily
disable a test. 
.TP
\fIwinCrash\fR
test crashes if it's run on Windows.  This flag is used to temporarily
disable a test. 
.TP
\fImacCrash\fR
test crashes if it's run on a Mac.  This flag is used to temporarily
disable a test. 
.TP
\fIemptyTest\fR
test is empty, and so not worth running, but it remains as a
place-holder for a test to be written in the future.  This constraint
has value false to cause tests to be skipped unless the user specifies
otherwise.
.TP
\fIknownBug\fR
test is known to fail and the bug is not yet fixed.  This constraint
has value false to cause tests to be skipped unless the user specifies
otherwise.
.TP
\fInonPortable\fR
test can only be run in some known development environment.
Some tests are inherently non-portable because they depend on things
like word length, file system configuration, window manager, etc.

This constraint has value false to cause tests to be skipped unless
the user specifies otherwise.  
.TP
\fIuserInteraction\fR
test requires interaction from the user.  This constraint has
value false to causes tests to be skipped unless the user specifies
otherwise.  
.TP
\fIinteractive\fR
test can only be run in if the interpreter is in interactive mode 
(when the global tcl_interactive variable is set to 1).
.TP
\fInonBlockFiles\fR
test can only be run if platform supports setting files into
614
615
616
617
618
619
620
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
test can only run if Unix user is not root
.TP
\fIeformat\fR
test can only run if app has a working version of sprintf with respect
to the "e" format of floating-point numbers.
.TP
\fIstdio\fR
test can only be run if the current app can be spawned via a pipe




















.SH "RUNNING TEST FILES"







































Use the following command to run a test file that uses package



















tcltest:
.DS



<shell> <testFile> ?<option> ?<value>?? ...
.DE















Command line options include (tcltest accessor procs that




correspond to each flag are listed at the end of each flag description






in parenthesis): 





















.RS
.TP
\fB-help\fR
display usage information.
.TP
\fB-singleproc <bool>\fR
if <bool> is 0, run test files in separate interpreters.  if 1, source test
files into the current intpreter. (tcltest::singleProcess)
.TP
\fB-verbose <levelList>\fR
set the level of verbosity to a list containing 0 or more of "body",
"pass", "skip", "start", and "error".  See the "Test output" section
for an explanation of this option.  (tcltest::verbose)  
.TP
\fB-match <matchList>\fR
only run tests that match one or more of the glob patterns in
<matchList>.  (tcltest::match)
.TP
\fB-skip <skipList>\fR
do not run tests that match one or more of the glob patterns in
<skipList>.  (tcltest::skip)
.TP
\fB-file <globPatternList>\fR
only source test files that match any of the items in
<globPatternList> relative to tcltest::testsDirectory.  
This option
only makes sense if you are running tests using "all.tcl" as the
<testFile> instead of running single test files directly.
(tcltest::matchFiles) 
.TP
\fB-notfile <globPatternList>\fR
source files except for those that match any of the items in
<globPatternList> relative to tcltest::testsDirectory.
This option
only makes sense if you are running tests using "all.tcl" as the
<testFile> instead of running single test files directly.
(tcltest::skipFiles) 
.TP
\fB-relateddir <globPatternList>\fR
only run tests in directories that match any of the items in
<globPatternList> relative to tcltest::testsDirectory.  
This option
only makes sense if you are running tests using "all.tcl" as the
<testFile> instead of running single test files directly.
(tcltest::matchDirectories) 

.TP
\fB-asidefromdir <globPatternList>\fR
run tests in directories except for those that match any of the items in
<globPatternList> relative to tcltest::testsDirectory.
This option
only makes sense if you are running tests using "all.tcl" as the
<testFile> instead of running single test files directly.
(tcltest::skipDirectories) 
.TP
\fB-constraints <list>\fR
tests with any constraints in <list> will not be skipped.  Note that
elements of <list> must exactly match the existing constraints.  This
is useful if you want to make sure that tests with a particular
constraint are run (for example, if the tester wants to run all tests
with the knownBug constraint).
(tcltest::testConstraint)
.TP
\fB-limitconstraints <bool>\fR
If the argument to this flag is 1, the test harness limits test runs
to those tests that match the constraints listed by the -constraints
flag. Use of this flag requires use of the -constraints flag.  The
default value for this flag is 0 (false).  This is useful if you want
to run \fBonly\fR those tests that match the constraints listed using
the -constraints option.  A tester might want to do this if (for
example) he were
interested in running only those tests that are constrained to be
unixOnly and no other tests.
(tcltest::limitConstraints)
.TP
\fB-load <script>\fR
will use the specified script to load the commands under test
(tcltest::loadTestedCommands). The default is the empty
script. See -loadfile below too. (tcltest::loadScript)
.TP
\fB-loadfile <scriptfile>\fR
will use the contents of the named file to load the commands under
test (tcltest::loadTestedCommands). See -load above too. The default
is the empty script. (tcltest::loadFile)
.TP
\fB-tmpdir <directoryName>\fR
put any temporary files (created with tcltest::makeFile and
tcltest::makeDirectory) into the named directory.  The default
location is tcltest::workingDirectory.  (tcltest::temporaryDirectory)
.TP
\fB-testdir <directoryName>\fR
search the test suite to execute in the named directory.  The default
location is tcltest::workingDirectory.  (tcltest::testsDirectory)
.TP
\fB-preservecore <level>\fR
check for core files.  This flag is used to determine how much
checking should be done for core files.  (tcltest::preserveCore)
.TP
\fB-debug <debugLevel>\fR
print debug information to stdout.  This is used to debug code in the
tcltest package.  (tcltest::debug)
.TP
\fB-outfile <filename>\fR 
print output generated by the tcltest package to the named file.  This
defaults to stdout.  Note that debug output always goes to stdout,
regardless of this flag's setting.  (tcltest::outputFile)
.TP
\fB-errfile <filename>\fR
print errors generated by the tcltest package to the named file.  This
defaults to stderr.  (tcltest::errorFile)
.RE
.PP
You can specify any of the above options on the command line or by
defining an environment variable named TCLTEST_OPTIONS containing a
list of options (e.g. "-debug 3 -verbose 'pass skip'").  This 
environment variable is evaluated before the command line arguments.
Options specified on the command line override those specified in 
TCLTEST_OPTIONS. 
.PP
A second way to run tets is to start up a shell, load the
\fBtcltest\fR package, and then source an appropriate test file or use
the test command.  To use the options in interactive mode, set
their corresponding tcltest namespace variables after loading the
package.
.PP
See \fI"Test Constraints"\fR for a list of all built-in constraint names.




.PP
A final way to run tests would be to specify which test files to run
within an \fIall.tcl\fR (or otherwise named) file.  This is the
approach used by the Tcl test suite.  This file loads the tcltest

package, sets the location of

the test directory (tcltest::testsDirectory), and then calls the
\fItcltest::runAllTests\fR proc, which determines which test
files to run, how to run them, and calls tcltest::cleanupTests to
determine the summary status of the test suite.  

.PP
A more elaborate \fIall.tcl\fR file might do some pre- and
post-processing before sourcing 
each .test file, use separate interpreters for each file, or handle
complex directory structures.  
For an example of an all.tcl file,
please see the "Examples" section of this document.

.SH "TEST OUTPUT"
After all specified test files are run, the number of tests
passed, skipped, and failed is printed to
\fBtcltest::outputChannel\fR.  Aside from this 


statistical information, output can be controlled on a per-test basis
by the \fBtcltest::verbose\fR variable.
.PP

\fBtcltest::verbose\fR can be set to any combination of "body", 
"skip", "pass", "start", or "error".  The default value of
\fBtcltest::verbose\fR is "body".  If "body"  is present, then the
entire body of the test is printed for each failed test, otherwise
only the test's name, desired output, and 
actual output, are printed for each failed test.  If "pass" is present,
then a line is printed for each passed test, otherwise no line is
printed for passed tests.  If "skip" is present, then a line (containing
the consraints that cause the test to be skipped) is printed for each
skipped test, otherwise no line is printed for skipped tests.  If "start"
is present, then a line is printed each time a new test starts.
If "error" is present, then the content of errorInfo and errorCode (if
they are defined) is printed for each test whose return code doesn't
match its expected return code.
.PP
You can set \fBtcltest::verbose\fR either interactively (after the
\fBtcltest\fR package has been loaded) or by using the command line


argument \fB-verbose\fR, for example:
.DS
tclsh socket.test -verbose 'body pass skip'




.DE
.SH "CONTENTS OF A TEST FILE"
Test files should begin by loading the \fBtcltest\fR package:
.DS

package require tcltest
namespace import -force tcltest::*
.DE
Test files should end by cleaning up after themselves and calling
\fBtcltest::cleanupTests\fR.  The \fBtcltest::cleanupTests\fR
procedure prints statistics about the number of tests that passed,


skipped, and failed, and removes all files that were created using the
\fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR procedures.
.DS
# Remove files created by these tests
# Change to original working directory
# Unset global arrays
tcltest::cleanupTests
return

.DE


When naming test files, file names should end with a .test extension.
The names of test files that contain regression (or glass-box) tests
should correspond to the Tcl or C code file that they are testing.
For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test".  
.SH "SELECTING TESTS FOR EXECUTION"
.PP

Normally, all the tests in a file are run whenever the file is

sourced.  An individual test will be skipped if one of the following
conditions is met:
.IP [1]
the \fIname\fR of the tests does not match (using glob style matching)
one or more elements in the \fBtcltest::match\fR variable
.IP [2]

the \fIname\fR of the tests matches (using glob style matching) one or
more elements in the \fBtcltest::skip\fR variable 

.IP [3]
the \fIconstraints\fR argument to the \fBtcltest::test\fR call, if
given, contains one or more false elements. 

.PP
You can set \fBtcltest::match\fR and/or \fBtcltest::skip\fR
either interactively (after the \fBtcltest\fR package has been
sourced), or by using the command line arguments \fB-match\fR and
\fB-skip\fR, for example: 
.PP
.CS
tclsh info.test -match '*-5.* *-7.*' -skip '*-7.1*'
.CE
.PP
Be sure to use the proper quoting convention so that your shell does
not perform the glob substitution on the match or skip patterns you
specify.
.PP
Predefined constraints (e.g. \fIknownBug\fR and \fInonPortable\fR) can be
overridden either interactively (after the \fBtcltest\fR package has been
sourced) by setting the proper constraint
or by using the \fB-constraints\fR command line option with the name of the
constraint in the argument.  The following example shows how to run
tests that are constrained by the \fIknownBug\fR and \fInonPortable\fR
restrictions:
.PP
.CS
tclsh all.tcl -constraints "knownBug nonPortable"


.CE
.PP
See the \fI"Constraints"\fR section for information about using
built-in constraints and adding new ones.
.PP
When tests are run from within an \fBall.tcl\fR file, all files with a
``\fI.test\fR'' extension are normally run.  An individual test file will
be skipped if one of the following conditions is met:
.IP [1]
the \fIname\fR of the test files does not match (using glob style matching)
one or more elements in the \fBtcltest::matchFiles\fR variable
.IP [2]
the \fIname\fR of the test file matches (using glob style matching) one or


more elements in the \fBtcltest::skipFiles\fR variable 
.PP



You can set \fBtcltest::matchFiles\fR and/or \fBtcltest::skipFiles\fR
either interactively (after the \fBtcltest\fR package has been
sourced), or by using the command line arguments \fB-file\fR and
\fB-notfile\fR, for example: 
.PP

.CS






tclsh info.test -file 'unix*.test' -notfile 'unixNotfy.test'
.CE
.PP
Additionally, if tests are run from within an 'all.tcl' containing a
call to \fBtcltest::runAllTests\fR, any subdirectory of
\fItcltest::testsDirectory\fR containing an 'all.tcl' file will also
be run.  Individual test subdirectories will be skipped if one of the
following conditions is met:
.IP [1]
the \fIname\fR of the directory does not match (using glob style matching)
one or more elements in the \fBtcltest::matchDirectories\fR variable
.IP [2]
the \fIname\fR of the directory matches (using glob style matching) one or
more elements in the \fBtcltest::skipDirectories\fR variable 
.PP
You can set \fBtcltest::matchDirectories\fR and/or \fBtcltest::skipDirectories\fR
either interactively (after the \fBtcltest\fR package has been
sourced), or by using the command line arguments \fB-relateddir\fR and
\fB-asidefromdir\fR, for example: 
.PP
.CS
tclsh info.test -relateddir 'subdir*' -asidefromdir 'subdir2'
.CE
.SH "HOW TO CUSTOMIZE THE TEST HARNESS"
To create your own custom test harness, create a .tcl file that contains your
namespace.  Within this file, require package \fBtcltest\fR.  Commands
that can be redefined to customize the test harness include:
.TP
\fBtcltest::PrintUsageInfoHook\fR
print additional usage information specific to your situation.
.TP



\fBtcltest::processCmdLineArgsFlagHook\fR






tell the test harness about additional flags that you want it to understand.
.TP

\fBtcltest::processCmdLineArgsHook\fR \fIflags\fR



process the additional flags that you told the harness about in
tcltest::processCmdLineArgsFlagHook.
.TP
\fBtcltest::cleanupTestsHook\fR
do additional cleanup 

.PP
.PP
To add new flags to your customized test harness, redefine
\fBtcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be
parsed and \fBtcltest::processCmdLineArgsHook\fR to actually process them.
For example:
.DS
proc tcltest::processCmdLineArgsAddFlagHook {} {
    return [list -flag1 -flag2]
}

proc tcltest::processCmdLineArgsHook {flagArray} {
    array set flag $flagArray

    if {[info exists flag(-flag1)]} {
        # Handle flag1
    }

    if {[info exists flag(-flag2)]} {
        # Handle flag2
    }

    return
}
.DE
You may also want to add usage information for these flags.  This
information would be displayed whenever the user specifies -help.  To
define additional usage information, define your own
tcltest::PrintUsageInfoHook proc.  Within this proc, you should
print out additional usage information for any flags that you've









implemented. 
.PP
Finally, if you want to add additional cleanup code to your harness
you can define your own \fBtcltest::cleanupTestsHook\fR.  For example:
.DS
proc tcltest::cleanupTestsHook {} {
    # Add your cleanup code here
}
.DE
.SH EXAMPLES
.IP [1] 
A simple test file (foo.test)

.DS
package require tcltest
namespace import -force ::tcltest::*

test foo-1.1 {save 1 in variable name foo} -body {set foo 1} -result 1

tcltest::cleanupTests

return

.DE
.IP [2] 
A simple all.tcl

.DS
package require tcltest
namespace import -force ::tcltest::*

tcltest::testsDirectory [file dir [info script]]
tcltest::runAllTests

return
.DE
.IP [3] 
Running a single test
.DS



tclsh foo.test
.DE
.IP [4] 
Running multiple tests

.DS
tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test'
.DE


.IP [5] 
A test that uses the unixOnly constraint and should only be
run on Unix
.DS

test getAttribute-1.1 {testing file permissions} {
    -constraints {unixOnly}
    -body {
        lindex [file attributes foo.tcl] 5
    }

    -result {00644}
}

.DE
.IP [6] 
A test containing an constraint expression that evaluates to true (a case where the test would be run) if it is being run on unix and if threads are not being tested
.DS
test testOnUnixWithoutThreads-1.1 {
    this test runs only on unix and only if we're not testing
    threads
} {
    -constraints {unixOnly && !testthread}
    -body {
        # some script goes here
    }
}
.DE

.SH "KNOWN ISSUES"
There are two known issues related to nested test commands.  
The first issue relates to the stack level in which test scripts are
executed.  Tests nested within other tests may be executed at the same
stack level as the outermost test.  For example, in the following test
code: 
.DS
test level-1.1 {level 1} {
    -body {
        test level-2.1 {level 2} {
        }
    }
}
.DE
any script executed in level-2.1 may be executed at the same stack
level as the script defined for level-1.1.  
.PP
In addition, while two
test commands have been run, results will only be reported for tests
at the same level as test level-1.1.  However, test results for all
tests run prior to level-1.1 will be available when test level-2.1
runs.  What this means is that if you try to access the test results
for test level-2.1, it will may say that 'm' tests have run, 'n' tests
have been skipped, 'o' tests have passed and 'p' tests have failed,
where 'm', 'n', 'o', and 'p' refer to tests that were run at the same
test level as test level-1.1. 
.PP
Implementation of output and error comparison in the test command
depends on usage of puts in your application code.  Output is
intercepted by redefining the puts command while the defined test
script is being run.  Errors thrown by C procedures or printed
directly from C applications will not be caught by the test command.
Therefore, usage of expect_out and expect_err in the test command is
useful only for pure Tcl applications that use the puts command for
output. 

.SH KEYWORDS
test, test harness, test suite







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
|
<
<
<
<
<
<
<
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<

|
|
|
<
<
<
|
|
<
<
<
<
<
<
|
>
>
>
>
|
<
<
<
>
|
>
|
<
|
<
>
|
|
<
<
|
<
<
>
|
<
<
<
>
>
|
<
|
>
|
|
<
<
<
<
<
<
<
|
<
<
<
<
|
<
|
>
>
|
|
<
>
>
>
>
|
<
|
<
>
|
<
|
<
<
<
>
>
|
<
|
<
<
|
|
<
>
|
>
>
|
|
<
<
<
|
>
|
>
|
<
|
|
<
<
>
|
<
>
|
<
<
>

<
<
<
<
<
<
<
<
<
|
|
<
<
<
|
<
<
<
<
<
<
|
<
>
>
|
<
<
<
<
<
<
<
<
|
|
<
<
>
>
|
|
>
>
>
|
<
<
<
<
>
|
>
>
>
>
>
>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
>
>
>
|
>
>
>
>
>
>
|
|
>
|
>
>
>
<
<
<
|
<
>
|
|
<
<
<
|
|
|
<
<
|
<
<
|
|
<
<
|
<
<
<
|
|
<
|
<
<
<
<
<
>
>
>
>
>
>
>
>
>
<
|
<
<
<
<
<
<
<
<
|
|
>
|
|
<
|
|
|
<
>
|
>
|
|
<
>
|
<
<
|
<
<
|
|
<
|
|
<
>
>
>
|
|
<
<
>
|
<
|
>
>
|
|
|
<
>
|
|
|
|
<
>
|
<
>
|
<
<
<
|
<
<
<
<
<
<
<
<
|
|

|


|
<
|






|



|
|
|
|
|
|
|
|
|






|
|
|



648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793

















794











795



796

797







798
799
















































800
801













802
803
804
805



806
807






808
809
810
811
812
813



814
815
816
817

818

819
820
821


822


823
824



825
826
827

828
829
830
831







832




833

834
835
836
837
838

839
840
841
842
843

844

845
846

847



848
849
850

851


852
853

854
855
856
857
858
859



860
861
862
863
864

865
866


867
868

869
870


871
872









873
874



875






876

877
878
879








880
881


882
883
884
885
886
887
888
889




890
891
892
893
894
895
896
897
























898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921



922

923
924
925



926
927
928


929


930
931


932



933
934

935





936
937
938
939
940
941
942
943
944

945








946
947
948
949
950

951
952
953

954
955
956
957
958

959
960


961


962
963

964
965

966
967
968
969
970


971
972

973
974
975
976
977
978

979
980
981
982
983

984
985

986
987



988








989
990
991
992
993
994
995

996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
test can only run if Unix user is not root
.TP
\fIeformat\fR
test can only run if app has a working version of sprintf with respect
to the "e" format of floating-point numbers.
.TP
\fIstdio\fR
test can only be run if [\fBinterpreter\fR] can be [\fBopen\fR]ed
as a pipe.
.PP
The alternative mode of constraint control is enabled by setting
[\fBconfigure -limitconstraints\fR] to true.  With that configuration
setting, all existing constraints other than those in the constraint
list returned by [\fBconfigure -constraints\fR] are set to false.
When the value of [\fBconfigure -constraints\fR]
is set, all those constraints are set to true.  The effect is that
when both options [\fBconfigure -constraints\fR] and
[\fBconfigure -limitconstraints\fR] are in use, only those tests including
only constraints from the [\fBconfigure -constraints\fR] list
are run; all others are skipped.  For example, one might set
up a configuration with
.CS
configure -constraints knownBug \e
          -limitconstraints true \e
          -verbose pass
.CE
to run exactly those tests that exercise known bugs, and discover
whether any of them pass, indicating the bug had been fixed.  
.SH "RUNNING ALL TESTS"
.PP
The single command [\fBrunAllTests\fR] is evaluated to run an entire
test suite, spanning many files and directories.  The configuration
options of \fBtcltest\fR control the precise operations.  The
[\fBrunAllTests\fR] command begins by printing a summary of its
configuration to [\fBoutputChannel\fR].
.PP
Test files to be evaluated are sought in the directory
[\fBconfigure -testdir\fR].  The list of files in that directory
that match any of the patterns in [\fBconfigure -file\fR] and
match none of the patterns in [\fBconfigure -notfile\fR] is generated
and sorted.  Then each file will be evaluated in turn.  If
[\fBconfigure -singleproc\fR] is true, then each file will
be [\fBsource\fR]d in the caller's context.  If if is false,
then a copy of [\fBinterpreter\fR] will be [\fBexec\fR]d to
evaluate each file.  The multi-process operation is useful
when testing can cause errors so severe that a process 
terminates.  Although such an error may terminate a child
process evaluating one file, the master process can continue
with the rest of the test suite.  In multi-process operation,
the configuration of \fBtcltest\fR in the master process is
passed to the child processes as command line arguments,
with the exception of [\fBconfigure -outfile\fR].  The
[\fBrunAllTests\fR] command in the
master process collects all output from the child processes
and collates their results into one master report.  Any
reports of individual test failures, or messages requested
by a [\fBconfigure -verbose\fR] setting are passed directly
on to [\fBoutputChannel\fR] by the master process.
.PP
After evaluating all selected test files, a summary of the
results is printed to [\fBoutputChannel\fR].  The summary
includes the total number of [\fBtest\fR]s evaluated, broken
down into those skipped, those passed, and those failed.
The summary also notes the number of files evaluated, and the names
of any files with failing tests or errors.  A list of
the constraints that caused tests to be skipped, and the
number of tests skipped for each is also printed.  Also,
messages are printed if it appears that evaluation of
a test file has caused any temporary files to be left
behind in [\fBconfigure -tmpdir\fR].
.PP
Having completed and summarized all selected test files,
[\fBrunAllTests\fR] then recursively acts on subdirectories
of [\fBconfigure -testdir\fR].  All subdirectories that
match any of the patterns in [\fBconfigure -relateddir\fR]
and do not match any of the patterns in
[\fBconfigure -asidefromdir\fR] are examined.  If
a file named \fBall.tcl\fR is found in such a directory,
it will be [\fBsource\fR]d in the caller's context.
Whether or not an examined directory contains an
\fBall.tcl\fR file, its subdirectories are also scanned
against the [\fBconfigure -relateddir\fR] and
[\fBconfigure -asidefromdir\fR] patterns.  In this way,
many directories in a directory tree can have all their
test files evaluated by a single [\fBrunAllTests\fR]
command.
.SH "CONFIGURABLE OPTIONS"
The [\fBconfigure\fR] command is used to set and query the configurable
options of \fBtcltest\fR.  The valid options are:
.TP
\fB-singleproc \fIboolean\fR
Controls whether or not [\fBrunAllTests\fR] spawns a child process for
each test file.  No spawning when \fIboolean\fR is true.  Default
value is false.
.TP
\fB-debug \fIlevel\fR
Sets the debug level to \fIlevel\fR, an integer value indicating how
much debugging information should be printed to stdout.  Note that
debug messages always go to stdout, independent of the value of
[\fBconfigure -outfile\fR].  Default value is 0.  Levels are defined as:
.RS
.IP 0
Do not display any debug information.
.IP 1
Display information regarding whether a test is skipped because it
doesn't match any of the tests that were specified using by
[\fBconfigure -match\fR] (userSpecifiedNonMatch) or matches any of
the tests specified by [\fBconfigure -skip\fR] (userSpecifiedSkip).  Also
print warnings about possible lack of cleanup or balance in test files.
.IP 2
Display the flag array parsed by the command line processor, the
contents of the ::env array, and all user-defined variables that exist
in the current namespace as they are used.
.IP 3
Display information regarding what individual procs in the test
harness are doing.
.RE
.TP
\fB-verbose \fIlevel\fR
Sets the type of output verbosity desired to \fIlevel\fR,
a list of zero or more of the elements \fBbody\fR, \fBpass\fR,
\fBskip\fR, \fBstart\fR, and \fBerror\fR.  Default value is \fBbody\fR.
Levels are defined as: 
.RS
.IP "body (b)"
Display the body of failed tests
.IP "pass (p)"
Print output when a test passes
.IP "skip (s)"
Print output when a test is skipped
.IP "start (t)"
Print output whenever a test starts
.IP "error (e)"
Print errorInfo and errorCode, if they exist, when a test return code
does not match its expected return code
.RE
The single letter abbreviations noted above are also recognized
so that [\fBconfigure -verbose pt\fR] is the same as
[\fBconfigure -verbose  {pass start}\fR].
.TP
\fB-preservecore \fIlevel\fR
Sets the core preservation level to \fIlevel\fR.  This level
determines how stringent checks for core files are.  Default
value is 0.  Levels are defined as:
.RS
.IP 0

















No checking - do not check for core files at the end of each test











command, but do check for them in [\fBrunAllTests\fR] after all



test files have been evaluated.

.IP 1







Also check for core files at the end of each [\fBtest\fR] command.
.IP 2
















































Check for core files at all times described above, and save a 
copy of each core file produced in [\fBconfigure -tmpdir\fR].













.RE
.TP
\fB-limitconstraints \fIboolean\fR
Sets the mode by which [\fBtest\fR] honors constraints as described



in \fBTESTS\fR above.  Default value is false.
.TP






\fB-constraints \fIlist\fR
Sets all the constraints in \fIlist\fR to true.  Also used in
combination with [\fBconfigure -limitconstraints true\fR] to control an
alternative constraint mode as described in \fBTESTS\fR above.
Default value is an empty list.
.TP



\fB-tmpdir \fIdirectory\fR
Sets the temporary directory to be used by [\fBmakeFile\fR],
[\fBmakeDirectory\fR], [\fBviewFile\fR], [\fBremoveFile\fR], 
and [\fBremoveDirectory\fR] as the default directory where

temporary files and directories created by test files should

be created.  Default value is [\fBworkingDirectory\fR].
.TP
\fB-testdir \fIdirectory\fR


Sets the directory searched by [\fBrunAllTests\fR] for test files


and subdirectories.  Default value is [\fBworkingDirectory\fR].
.TP



\fB-file \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what test files to evaluate.  Default value is \fB*.test\fR.

.TP
\fB-notfile \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what test files to skip.  Default value is \fBl.*.test\fR, so







that any SCCS lock files are skipped.




.TP

\fB-relateddir \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what subdirectories to search for an \fBall.tcl\fR file.  Default
value is \fB*\fR.
.TP

\fB-asidefromdir \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what subdirectories to skip when searching for an \fBall.tcl\fR file.
Default value is an empty list.
.TP

\fB-match \fIpatternList\fR

Set the list of patterns used by [\fBtest\fR] to determine whether
a test should be run.  Default value is \fB*\fR.

.TP



\fB-skip \fIpatternList\fR
Set the list of patterns used by [\fBtest\fR] to determine whether
a test should be skipped.  Default value is an empty list.

.TP


\fB-load \fIscript\fR
Sets a script to be evaluated by [\fBloadTestedCommands\fR].

Default value is an empty script.
.TP
\fB-loadfile \fIfilename\fR
Sets the filename from which to read a script to be evaluated
by [\fBloadTestedCommands\fR].  This is an alternative to
\fB-load\fR.  They cannot be used together.



.TP
\fB-outfile \fIfilename\fR 
Sets the file to which all output produced by tcltest should be
written.  A file named \fIfilename\fR will be [\fBopen\fR]ed for writing,
and the resulting channel will be set as the value of [\fBoutputChannel\fR].

.TP
\fB-errfile \fIfilename\fR


Sets the file to which all error output produced by tcltest
should be written.  A file named \fIfilename\fR will be [\fBopen\fR]ed

for writing, and the resulting channel will be set as the value
of [\fBerrorChannel\fR].


.SH "CREATING TEST SUITES WITH TCLTEST"
.PP









This section intentionally, temporarily left blank.
'\" .SH "CONTENTS OF A TEST FILE"



'\" Test files should begin by loading the \fBtcltest\fR package:






'\" .CS

'\" package require tcltest
'\" namespace import -force tcltest::*
'\" .CE








'\" Test files should end by cleaning up after themselves and calling
'\" \fBtcltest::cleanupTests\fR.  The \fBtcltest::cleanupTests\fR


'\" procedure prints statistics about the number of tests that passed,
'\" skipped, and failed, and removes all files that were created using the
'\" \fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR procedures.
'\" .CS
'\" # Remove files created by these tests
'\" # Change to original working directory
'\" # Unset global arrays
'\" tcltest::cleanupTests




'\" return
'\" .CE
'\" When naming test files, file names should end with a .test extension.
'\" The names of test files that contain regression (or glass-box) tests
'\" should correspond to the Tcl or C code file that they are testing.
'\" For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test".  
'\" 
'\" .SH "HOW TO CUSTOMIZE THE TEST HARNESS"
























'\" To create your own custom test harness, create a .tcl file that contains your
'\" namespace.  Within this file, require package \fBtcltest\fR.  Commands
'\" that can be redefined to customize the test harness include:
'\" .TP
'\" \fBtcltest::cleanupTestsHook\fR
'\" do additional cleanup 
'\" .PP
'\" To add additional cleanup code to your harness
'\" you can define your own \fBtcltest::cleanupTestsHook\fR.  For example:
'\" .CS
'\" proc tcltest::cleanupTestsHook {} {
'\"     # Add your cleanup code here
'\" }
'\" .CE
'\" 
'\" .SH EXAMPLES
'\" .IP [1] 
'\" A simple test file (foo.test)
'\" .CS
'\" package require tcltest
'\" namespace import -force ::tcltest::*
'\" 
'\" test foo-1.1 {save 1 in variable name foo} -body {set foo 1} -result 1
'\" 



'\" tcltest::cleanupTests

'\" return
'\" .CE
'\" .IP [2] 



'\" A simple all.tcl
'\" .CS
'\" package require tcltest


'\" namespace import -force ::tcltest::*


'\" 
'\" tcltest::testsDirectory [file dir [info script]]


'\" tcltest::runAllTests



'\" 
'\" return

'\" .CE





'\" .IP [3] 
'\" Running a single test
'\" .CS
'\" tclsh foo.test
'\" .CE
'\" .IP [4] 
'\" Running multiple tests
'\" .CS
'\" tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test'

'\" .CE








'\" .IP [5] 
'\" A test that uses the \fBunix\fR constraint and should only be
'\" run on Unix
'\" .CS
'\" test getAttribute-1.1 {testing file permissions} {

'\"     -constraints {unix}
'\"     -body {
'\"         lindex [file attributes foo.tcl] 5

'\"     }
'\"     -result {00644}
'\" }
'\" .CE
'\" .IP [6] 

'\" A test containing an constraint expression that evaluates to true (a case where the test would be run) if it is being run on unix and if threads are not being tested
'\" .CS


'\" test testOnUnixWithoutThreads-1.1 {


'\"     this test runs only on unix and only if we're not testing
'\"     threads

'\" } {
'\"     -constraints {unix && !testthread}

'\"     -body {
'\"         # some script goes here
'\"     }
'\" }
'\" .CE


'\" 
.SH COMPATIBILITY

.PP
A number of commands and variables in the \fB::tcltest\fR namespace
provided by earlier releases of \fBtcltest\fR have not been documented
here.  They are no longer part of the supported public interface of
\fBtcltest\fR and should not be used in new test suites.  However,
to continue to support existing test suites written to the older

interface specifications, many of those deprecated commands and
variables still work as before.  For example, in many circumstances,
[\fBconfigure\fR] will be automatically called shortly after
[\fBpackage require tcltest 2.1\fR] succeeds with arguments
from the variable \fB::argv\fR.  This is to support test suites

that depend on the old behavior that \fBtcltest\fR was automatically
configured from command line arguments.  New test files should not

depend on this, but should explicitly include
.CS



eval tcltest::configure $::argv








.CE
to establish a configuration from command line arguments.
.SH "KNOWN ISSUES"
There are two known issues related to nested evaluations of [\fBtest\fR].  
The first issue relates to the stack level in which test scripts are
executed.  Tests nested within other tests may be executed at the same
stack level as the outermost test.  For example, in the following code: 

.CS
test level-1.1 {level 1} {
    -body {
        test level-2.1 {level 2} {
        }
    }
}
.CE
any script executed in level-2.1 may be executed at the same stack
level as the script defined for level-1.1.  
.PP
In addition, while two [\fBtest\fR]s have been run, results will only
be reported by [\fBcleanupTests\fR] for tests at the same level as
test level-1.1.  However, test results for all tests run prior to
level-1.1 will be available when test level-2.1 runs.  What this
means is that if you try to access the test results for test level-2.1,
it will may say that 'm' tests have run, 'n' tests have been skipped,
'o' tests have passed and 'p' tests have failed, where 'm', 'n', 'o',
and 'p' refer to tests that were run at the same test level as
test level-1.1. 
.PP
Implementation of output and error comparison in the test command
depends on usage of puts in your application code.  Output is
intercepted by redefining the puts command while the defined test
script is being run.  Errors thrown by C procedures or printed
directly from C applications will not be caught by the test command.
Therefore, usage of the \fB-output\fR and \fB-errorOuput\fR
options to [\fBtest\fR] is useful only for pure Tcl applications
that use [\fBputs\fR] to produce output. 

.SH KEYWORDS
test, test harness, test suite
Changes to doc/tclvars.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tclvars.n,v 1.9.4.2 2002/06/10 05:33:08 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tclvars.n,v 1.9.4.3 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
tclvars \- Variables used by Tcl
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
capitalization are converted automatically to upper case.  For instance, the
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases.  All other environment variables inherited by
Tcl are left unmodified.  Setting an env array variable to blank is the
same as unsetting it as this is the behavior of the underlying Windows OS.
It should be noted that relying on an existing and empty environment variable
won't work on windows and is discoraged for cross-platform usage.
.VE
.RE
.RS
On the Macintosh, the environment variable is constructed by Tcl as no
global environment variable exists.  The environment variables that
are created for Tcl include:
.TP







|







42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
capitalization are converted automatically to upper case.  For instance, the
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases.  All other environment variables inherited by
Tcl are left unmodified.  Setting an env array variable to blank is the
same as unsetting it as this is the behavior of the underlying Windows OS.
It should be noted that relying on an existing and empty environment variable
won't work on windows and is discouraged for cross-platform usage.
.VE
.RE
.RS
On the Macintosh, the environment variable is constructed by Tcl as no
global environment variable exists.  The environment variables that
are created for Tcl include:
.TP
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
\fBbyteOrder\fR
The native byte order of this machine: either \fBlittleEndian\fR or
\fBbigEndian\fR. 
.VE
.TP
\fBdebug\fR
If this variable exists, then the interpreter
was compiled with debugging symbols enabled.  This varible will only
exist on Windows so extension writers can specify which package to load
depending on the C run-time library that is loaded.
.TP
\fBmachine\fR
The instruction set executed by this machine, such as
\fBintel\fR, \fBPPC\fR, \fB68k\fR, or \fBsun4m\fR.  On UNIX machines, this
is the value returned by \fBuname -m\fR.







|







254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
\fBbyteOrder\fR
The native byte order of this machine: either \fBlittleEndian\fR or
\fBbigEndian\fR. 
.VE
.TP
\fBdebug\fR
If this variable exists, then the interpreter
was compiled with debugging symbols enabled.  This variable will only
exist on Windows so extension writers can specify which package to load
depending on the C run-time library that is loaded.
.TP
\fBmachine\fR
The instruction set executed by this machine, such as
\fBintel\fR, \fBPPC\fR, \fB68k\fR, or \fBsun4m\fR.  On UNIX machines, this
is the value returned by \fBuname -m\fR.
Changes to doc/trace.n.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: trace.n,v 1.8 2001/01/16 15:41:06 dkf Exp $
'\" 
.so man.macros
.TH trace n "8.4" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
trace \- Monitor variable accesses and command usages
.SH SYNOPSIS
\fBtrace \fIoption\fR ?\fIarg arg ...\fR?
.BE

.SH DESCRIPTION
.PP
This command causes Tcl commands to be executed whenever certain operations are
invoked.  The legal \fIoption\fR's (which may be abbreviated) are:
.TP
\fBtrace add \fItype name ops ?args?\fR
Where \fItype\fR is \fBcommand\fR, or \fBvariable\fR.
.RS
.TP
\fBtrace add command\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is modified in one of the ways given by the list \fIops\fR.  \fIName\fR will be
resolved using the usual namespace resolution rules used by
procedures.  If the command does not exist, an error will be thrown.








|






|










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: trace.n,v 1.8.14.1 2002/08/20 20:25:24 das Exp $
'\" 
.so man.macros
.TH trace n "8.4" Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
trace \- Monitor variable accesses, command usages and command executions
.SH SYNOPSIS
\fBtrace \fIoption\fR ?\fIarg arg ...\fR?
.BE

.SH DESCRIPTION
.PP
This command causes Tcl commands to be executed whenever certain operations are
invoked.  The legal \fIoption\fR's (which may be abbreviated) are:
.TP
\fBtrace add \fItype name ops ?args?\fR
Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR.
.RS
.TP
\fBtrace add command\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is modified in one of the ways given by the list \fIops\fR.  \fIName\fR will be
resolved using the usual namespace resolution rules used by
procedures.  If the command does not exist, an error will be thrown.
45
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68































































































69
70
71
72
73
74
75
\fBdelete\fR
Invoke \fIcommand\fR when the command is deleted.  Commands can be
deleted explicitly by using the \fBrename\fR command to rename the
command to an empty string.  Commands are also deleted when the
interpreter is deleted, but traces will not be invoked because there is no
interpreter in which to execute them.
.PP
When the trace triggers, three arguments are appended to

\fIcommand\fR so that the actual command is as follows:
.CS
\fIcommand oldName newName op\fR
.CE
\fIOldName\fR and \fInewName\fR give the traced command's current
(old) namename, and the name to which it is being renamed (the empty
string if this is a 'delete' operation).
\fIOp\fR indicates what operation is being performed on the
variable, and is one of \fBrename\fR or \fBdelete\fR as
defined above.  The trace operation cannot be used to stop a command
from being deleted.  Tcl will always remove the command once the trace
is complete.  Recursive renaming or deleting will not cause further traces 
of the same type to be evaluated, so a delete trace which itself
deletes the command, or a rename trace which itself renames the
command will not cause further trace evaluations to occur.
.RE































































































.TP
\fBtrace add variable\fI name ops command\fR
Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR
is accessed in one of the ways given by the list \fIops\fR.  \fIName\fR may
refer to a normal variable, an element of an array, or to an array
as a whole (i.e. \fIname\fR may be just the name of an array, with no
parenthesized index).  If \fIname\fR refers to a whole array, then







|
>
|




|


|







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
\fBdelete\fR
Invoke \fIcommand\fR when the command is deleted.  Commands can be
deleted explicitly by using the \fBrename\fR command to rename the
command to an empty string.  Commands are also deleted when the
interpreter is deleted, but traces will not be invoked because there is no
interpreter in which to execute them.
.PP
When the trace triggers, depending on the operations being traced, a 
number of arguments are appended to \fIcommand\fR so that the actual 
command is as follows:
.CS
\fIcommand oldName newName op\fR
.CE
\fIOldName\fR and \fInewName\fR give the traced command's current
(old) name, and the name to which it is being renamed (the empty
string if this is a 'delete' operation).
\fIOp\fR indicates what operation is being performed on the
command, and is one of \fBrename\fR or \fBdelete\fR as
defined above.  The trace operation cannot be used to stop a command
from being deleted.  Tcl will always remove the command once the trace
is complete.  Recursive renaming or deleting will not cause further traces 
of the same type to be evaluated, so a delete trace which itself
deletes the command, or a rename trace which itself renames the
command will not cause further trace evaluations to occur.
.RE
.TP
\fBtrace add execution\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is modified in one of the ways given by the list \fIops\fR.  \fIName\fR will be
resolved using the usual namespace resolution rules used by
procedures.  If the command does not exist, an error will be thrown.
.RS
.PP
\fIOps\fR indicates which operations are of interest, and is a list of
one or more of the following items:
.TP
\fBenter\fR
Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
just before the actual execution takes place.
.TP
\fBleave\fR
Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
just after the actual execution takes place.
.TP
\fBenterstep\fR
Invoke \fIcommand\fR for every tcl command which is executed 
inside the procedure \fIname\fR, just before the actual execution
takes place.  For example if we have 'proc foo {} { puts "hello" }',
then a \fIenterstep\fR trace would be 
invoked just before \fIputs "hello"\fR is executed.
Setting a \fIenterstep\fR trace on a \fIcommand\fR
will not result in an error and is simply ignored.
.TP
\fBleavestep\fR
Invoke \fIcommand\fR for every tcl command which is executed 
inside the procedure \fIname\fR, just after the actual execution
takes place.
Setting a \fIleavestep\fR trace on a \fIcommand\fR
will not result in an error and is simply ignored.
.PP
When the trace triggers, depending on the operations being traced, a 
number of arguments are appended to \fIcommand\fR so that the actual 
command is as follows:

For \fBenter\fR and \fBenterstep\fR operations:
.CS
\fIcommand command-string op\fR
.CE
\fICommand-string\fR gives the complete current command being 
executed (the traced command for a \fBenter\fR operation, an 
arbitrary command for a \fBenterstep\fR operation), including
all arguments in their fully expanded form.
\fIOp\fR indicates what operation is being performed on the
command execution, and is one of \fBenter\fR or \fBenterstep\fR as
defined above.  The trace operation can be used to stop the
command from executing, by deleting the command in question.  Of
course when the command is subsequently executed, an 'invalid command'
error will occur.
.TP
For \fBleave\fR and \fBleavestep\fR operations:
.CS
\fIcommand command-string code result op\fR
.CE
\fICommand-string\fR gives the complete current command being 
executed (the traced command for a \fBenter\fR operation, an 
arbitrary command for a \fBenterstep\fR operation), including
all arguments in their fully expanded form.
\fICode\fR gives the result code of that execution, and \fIresult\fR
the result string.
\fIOp\fR indicates what operation is being performed on the
command execution, and is one of \fBleave\fR or \fBleavestep\fR as
defined above.  
Note that the creation of many \fBenterstep\fR or
\fBleavestep\fR traces can lead to unintuitive results, since the
invoked commands from one trace can themselves lead to further
command invocations for other traces.

\fICommand\fR executes in the same context as the code that invoked
the traced operation: thus the \fIcommand\fR, if invoked from a procedure,
will have access to the same local variables as code in the procedure.
This context may be different than the context in which the trace was
created. If \fIcommand\fR invokes a procedure (which it normally does)
then the procedure will have to use upvar or uplevel commands if it wishes
to access the local variables of the code which invoked the trace operation.

While \fIcommand\fR is executing during an execution trace, traces
on \fIname\fR are temporarily disabled. This allows the \fIcommand\fR
to execute \fIname\fR in its body without invoking any other traces again.
If an error occurs while executing the \fIcommand\fR body, then the
\fIcommand\fR name as a whole will return that same error.

When multiple traces are set on \fIname\fR, then for \fIenter\fR
and \fIenterstep\fR operations, the traced commands are invoked
in the reverse order of how the traces were originally created;
and for \fIleave\fR and \fIleavestep\fR operations, the traced
commands are invoked in the original order of creation.

The behavior of execution traces is currently undefined for a command 
\fIname\fR imported into another namespace.
.RE
.TP
\fBtrace add variable\fI name ops command\fR
Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR
is accessed in one of the ways given by the list \fIops\fR.  \fIName\fR may
refer to a normal variable, an element of an array, or to an array
as a whole (i.e. \fIname\fR may be just the name of an array, with no
parenthesized index).  If \fIname\fR refers to a whole array, then
179
180
181
182
183
184
185
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
but will not remove traces on the overall array.
.PP
This command returns an empty string.
.RE
.RE
.TP
\fBtrace remove \fItype name opList command\fR
Where \fItype\fR is either \fBcommand\fR or \fBvariable\fR.
.RS
.TP
\fBtrace remove command\fI name opList command\fR







If there is a trace set on command \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked.  Returns
an empty string.   If \fIname\fR doesn't exist, the command will throw
an error.
.TP
\fBtrace remove variable\fI name opList command\fR
If there is a trace set on variable \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked.  Returns
an empty string.
.RE
.TP
\fBtrace list \fItype name\fR
Where \fItype\fR is either \fBcommand\fR or \fBvariable\fR.
.RS
.TP
\fBtrace list command\fI name\fR








Returns a list containing one element for each trace currently set on
command \fIname\fR. Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace.  If \fIname\fR doesn't have any traces set,
then the result of the command will be an empty string.  If \fIname\fR
doesn't exist, the command will throw an error.
.TP
\fBtrace list variable\fI name\fR
Returns a list containing one element for each trace currently set on
variable \fIname\fR.  Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace.  If \fIname\fR doesn't exist or doesn't
have any traces set, then the result of the command will be an empty
string.
.RE
.PP
For backwards compatibility, three other subcommands are available:
.RS
.TP
\fBtrace variable \fIname ops command\fR
This is equivalent to \fBtrace add variable \fIname ops command\fR.
.TP
\fBtrace vdelete \fIname ops command\fR
This is equivalent to \fBtrace remove variable \fIname ops command\fR
.TP 
\fBtrace vinfo \fIname\fR 
This is equivalent to \fBtrace list variable \fIname\fR
.RE
.PP
These subcommands are deprecated and will likely be removed in a
future version of Tcl.  They use an older syntax in which \fBarray\fR,
\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR,
\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a
list, but simply a string concatenation of the operations, such as







|



>
>
>
>
>
>
>













|
|


|
>
>
>
>
>
>
>
>







|


















|







275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
but will not remove traces on the overall array.
.PP
This command returns an empty string.
.RE
.RE
.TP
\fBtrace remove \fItype name opList command\fR
Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR.
.RS
.TP
\fBtrace remove command\fI name opList command\fR
If there is a trace set on command \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked.  Returns
an empty string.   If \fIname\fR doesn't exist, the command will throw
an error.
.TP
\fBtrace remove execution\fI name opList command\fR
If there is a trace set on command \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked.  Returns
an empty string.   If \fIname\fR doesn't exist, the command will throw
an error.
.TP
\fBtrace remove variable\fI name opList command\fR
If there is a trace set on variable \fIname\fR with the operations and
command given by \fIopList\fR and \fIcommand\fR, then the trace is
removed, so that \fIcommand\fR will never again be invoked.  Returns
an empty string.
.RE
.TP
\fBtrace info \fItype name\fR
Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR.
.RS
.TP
\fBtrace info command\fI name\fR
Returns a list containing one element for each trace currently set on
command \fIname\fR. Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace.  If \fIname\fR doesn't have any traces set,
then the result of the command will be an empty string.  If \fIname\fR
doesn't exist, the command will throw an error.
.TP
\fBtrace info execution\fI name\fR
Returns a list containing one element for each trace currently set on
command \fIname\fR. Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace.  If \fIname\fR doesn't have any traces set,
then the result of the command will be an empty string.  If \fIname\fR
doesn't exist, the command will throw an error.
.TP
\fBtrace info variable\fI name\fR
Returns a list containing one element for each trace currently set on
variable \fIname\fR.  Each element of the list is itself a list
containing two elements, which are the \fIopList\fR and \fIcommand\fR
associated with the trace.  If \fIname\fR doesn't exist or doesn't
have any traces set, then the result of the command will be an empty
string.
.RE
.PP
For backwards compatibility, three other subcommands are available:
.RS
.TP
\fBtrace variable \fIname ops command\fR
This is equivalent to \fBtrace add variable \fIname ops command\fR.
.TP
\fBtrace vdelete \fIname ops command\fR
This is equivalent to \fBtrace remove variable \fIname ops command\fR
.TP 
\fBtrace vinfo \fIname\fR 
This is equivalent to \fBtrace info variable \fIname\fR
.RE
.PP
These subcommands are deprecated and will likely be removed in a
future version of Tcl.  They use an older syntax in which \fBarray\fR,
\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR,
\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a
list, but simply a string concatenation of the operations, such as
Changes to generic/regc_cvec.c.
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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

/*
 - newcvec - allocate a new cvec
 ^ static struct cvec *newcvec(int, int, int);
 */
static struct cvec *
newcvec(nchrs, nranges, nmcces)
int nchrs;			/* to hold this many chrs... */
int nranges;			/* ... and this many ranges... */
int nmcces;			/* ... and this many MCCEs */
{
	size_t n;
	size_t nc;
	struct cvec *cv;

	nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
	n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) +
								nc*sizeof(chr);
	cv = (struct cvec *)MALLOC(n);
	if (cv == NULL)
		return NULL;

	cv->chrspace = nc;
	cv->chrs = (chr *)&cv->mcces[nmcces];	/* chrs just after MCCE ptrs */
	cv->mccespace = nmcces;
	cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
	cv->rangespace = nranges;
	return clearcvec(cv);
}

/*
 - clearcvec - clear a possibly-new cvec
 * Returns pointer as convenience.
 ^ static struct cvec *clearcvec(struct cvec *);
 */
static struct cvec *
clearcvec(cv)
struct cvec *cv;
{
	int i;

	assert(cv != NULL);
	cv->nchrs = 0;
	assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
	cv->nmcces = 0;
	cv->nmccechrs = 0;
	cv->nranges = 0;
	for (i = 0; i < cv->mccespace; i++)
		cv->mcces[i] = NULL;


	return cv;
}

/*
 - addchr - add a chr to a cvec
 ^ static VOID addchr(struct cvec *, pchr);
 */
static VOID
addchr(cv, c)
struct cvec *cv;
pchr c;
{
	assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
	cv->chrs[cv->nchrs++] = (chr)c;
}

/*
 - addrange - add a range to a cvec
 ^ static VOID addrange(struct cvec *, pchr, pchr);
 */
static VOID
addrange(cv, from, to)
struct cvec *cv;
pchr from;
pchr to;
{
	assert(cv->nranges < cv->rangespace);
	cv->ranges[cv->nranges*2] = (chr)from;
	cv->ranges[cv->nranges*2 + 1] = (chr)to;
	cv->nranges++;
}

/*
 - addmcce - add an MCCE to a cvec
 ^ static VOID addmcce(struct cvec *, chr *, chr *);
 */
static VOID
addmcce(cv, startp, endp)
struct cvec *cv;
chr *startp;			/* beginning of text */
chr *endp;			/* just past end of text */
{
	int len;
	int i;
	chr *s;
	chr *d;

	if (startp == NULL && endp == NULL)
		return;

	len = endp - startp;
	assert(len > 0);
	assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs);
	assert(cv->nmcces < cv->mccespace);
	d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1];
	cv->mcces[cv->nmcces++] = d;
	for (s = startp, i = len; i > 0; s++, i--)
		*d++ = *s;

	*d++ = 0;		/* endmarker */
	assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
	cv->nmccechrs += len + 1;
}

/*
 - haschr - does a cvec contain this chr?
 ^ static int haschr(struct cvec *, pchr);
 */
static int			/* predicate */
haschr(cv, c)
struct cvec *cv;
pchr c;
{
	int i;
	chr *p;

	for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--)
		if (*p == c)
			return 1;


	for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--)
		if (*p <= c && c <= *(p+1))
			return 1;


	return 0;
}

/*
 - getcvec - get a cvec, remembering it as v->cv
 ^ static struct cvec *getcvec(struct vars *, int, int, int);
 */
static struct cvec *
getcvec(v, nchrs, nranges, nmcces)
struct vars *v;
int nchrs;			/* to hold this many chrs... */
int nranges;			/* ... and this many ranges... */
int nmcces;			/* ... and this many MCCEs */
{
	if (v->cv != NULL && nchrs <= v->cv->chrspace &&
					nranges <= v->cv->rangespace &&
					nmcces <= v->cv->mccespace)
		return clearcvec(v->cv);


	if (v->cv != NULL)
		freecvec(v->cv);

	v->cv = newcvec(nchrs, nranges, nmcces);
	if (v->cv == NULL)
		ERR(REG_ESPACE);


	return v->cv;
}

/*
 - freecvec - free a cvec
 ^ static VOID freecvec(struct cvec *);
 */
static VOID
freecvec(cv)
struct cvec *cv;
{
	FREE(cv);
}







|
|
|

|
|
|

|
|
|
|
|
|
>
|
|
|
|
|
|









|

|

|
|
|
|
|
|
|
|
|
>
|








|
|

|
|








|
|
|

|
|
|
|








|
|
|

|
|
|
|

|
|
>
|
|
|
|
|
|
|
|
>
|
|
|






|

|
|

|
|

|
|
|
>
>
|
|
|
>
>
|








|
|
|
|

|
|
<
|
|
>
|
|
>
|
|
|
|
>
|








|

|

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184

185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208

/*
 - newcvec - allocate a new cvec
 ^ static struct cvec *newcvec(int, int, int);
 */
static struct cvec *
newcvec(nchrs, nranges, nmcces)
    int nchrs;				/* to hold this many chrs... */
    int nranges;			/* ... and this many ranges... */
    int nmcces;				/* ... and this many MCCEs */
{
    size_t n;
    size_t nc;
    struct cvec *cv;

    nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
    n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *)
	    + nc*sizeof(chr);
    cv = (struct cvec *)MALLOC(n);
    if (cv == NULL) {
	return NULL;
    }
    cv->chrspace = nchrs;
    cv->chrs = (chr *)&cv->mcces[nmcces];	/* chrs just after MCCE ptrs */
    cv->mccespace = nmcces;
    cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
    cv->rangespace = nranges;
    return clearcvec(cv);
}

/*
 - clearcvec - clear a possibly-new cvec
 * Returns pointer as convenience.
 ^ static struct cvec *clearcvec(struct cvec *);
 */
static struct cvec *
clearcvec(cv)
    struct cvec *cv;			/* character vector */
{
    int i;

    assert(cv != NULL);
    cv->nchrs = 0;
    assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
    cv->nmcces = 0;
    cv->nmccechrs = 0;
    cv->nranges = 0;
    for (i = 0; i < cv->mccespace; i++) {
	cv->mcces[i] = NULL;
    }

    return cv;
}

/*
 - addchr - add a chr to a cvec
 ^ static VOID addchr(struct cvec *, pchr);
 */
static VOID
addchr(cv, c)
    struct cvec *cv;			/* character vector */
    pchr c;				/* character to add */
{
    assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
    cv->chrs[cv->nchrs++] = (chr)c;
}

/*
 - addrange - add a range to a cvec
 ^ static VOID addrange(struct cvec *, pchr, pchr);
 */
static VOID
addrange(cv, from, to)
    struct cvec *cv;			/* character vector */
    pchr from;				/* first character of range */
    pchr to;				/* last character of range */
{
    assert(cv->nranges < cv->rangespace);
    cv->ranges[cv->nranges*2] = (chr)from;
    cv->ranges[cv->nranges*2 + 1] = (chr)to;
    cv->nranges++;
}

/*
 - addmcce - add an MCCE to a cvec
 ^ static VOID addmcce(struct cvec *, chr *, chr *);
 */
static VOID
addmcce(cv, startp, endp)
    struct cvec *cv;			/* character vector */
    chr *startp;			/* beginning of text */
    chr *endp;				/* just past end of text */
{
    int len;
    int i;
    chr *s;
    chr *d;

    if (startp == NULL && endp == NULL) {
	return;
    }
    len = endp - startp;
    assert(len > 0);
    assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs);
    assert(cv->nmcces < cv->mccespace);
    d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1];
    cv->mcces[cv->nmcces++] = d;
    for (s = startp, i = len; i > 0; s++, i--) {
	*d++ = *s;
    }
    *d++ = 0;				/* endmarker */
    assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
    cv->nmccechrs += len + 1;
}

/*
 - haschr - does a cvec contain this chr?
 ^ static int haschr(struct cvec *, pchr);
 */
static int				/* predicate */
haschr(cv, c)
    struct cvec *cv;			/* character vector */
    pchr c;				/* character to test for */
{
    int i;
    chr *p;

    for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) {
	if (*p == c) {
	    return 1;
	}
    }
    for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) {
	if ((*p <= c) && (c <= *(p+1))) {
	    return 1;
	}
    }
    return 0;
}

/*
 - getcvec - get a cvec, remembering it as v->cv
 ^ static struct cvec *getcvec(struct vars *, int, int, int);
 */
static struct cvec *
getcvec(v, nchrs, nranges, nmcces)
    struct vars *v;			/* context */
    int nchrs;				/* to hold this many chrs... */
    int nranges;			/* ... and this many ranges... */
    int nmcces;				/* ... and this many MCCEs */
{
    if (v->cv != NULL && nchrs <= v->cv->chrspace &&
	    nranges <= v->cv->rangespace && nmcces <= v->cv->mccespace) {

	return clearcvec(v->cv);
    }

    if (v->cv != NULL) {
	freecvec(v->cv);
    }
    v->cv = newcvec(nchrs, nranges, nmcces);
    if (v->cv == NULL) {
	ERR(REG_ESPACE);
    }

    return v->cv;
}

/*
 - freecvec - free a cvec
 ^ static VOID freecvec(struct cvec *);
 */
static VOID
freecvec(cv)
    struct cvec *cv;			/* character vector */
{
    FREE(cv);
}
Changes to generic/regc_locale.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
/* 
 * regc_locale.c --
 *
 *	This file contains the Unicode locale specific regexp routines.
 *	This file is #included by regcomp.c.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: regc_locale.c,v 1.6.10.2 2002/06/10 05:33:08 wolfsuit Exp $
 */

/* ASCII character-name table */

static struct cname {
	char *name;
	char code;
} cnames[] = {
	{"NUL",	'\0'},
	{"SOH",	'\001'},
	{"STX",	'\002'},
	{"ETX",	'\003'},
	{"EOT",	'\004'},
	{"ENQ",	'\005'},
	{"ACK",	'\006'},
	{"BEL",	'\007'},
	{"alert",	'\007'},
	{"BS",		'\010'},
	{"backspace",	'\b'},
	{"HT",		'\011'},
	{"tab",		'\t'},
	{"LF",		'\012'},
	{"newline",	'\n'},
	{"VT",		'\013'},
	{"vertical-tab",	'\v'},
	{"FF",		'\014'},
	{"form-feed",	'\f'},
	{"CR",		'\015'},
	{"carriage-return",	'\r'},
	{"SO",	'\016'},
	{"SI",	'\017'},
	{"DLE",	'\020'},
	{"DC1",	'\021'},
	{"DC2",	'\022'},
	{"DC3",	'\023'},
	{"DC4",	'\024'},
	{"NAK",	'\025'},
	{"SYN",	'\026'},
	{"ETB",	'\027'},
	{"CAN",	'\030'},
	{"EM",	'\031'},
	{"SUB",	'\032'},
	{"ESC",	'\033'},
	{"IS4",	'\034'},
	{"FS",	'\034'},
	{"IS3",	'\035'},
	{"GS",	'\035'},
	{"IS2",	'\036'},
	{"RS",	'\036'},

	{"IS1",	'\037'},
	{"US",	'\037'},
	{"space",		' '},
	{"exclamation-mark",	'!'},
	{"quotation-mark",	'"'},
	{"number-sign",		'#'},
	{"dollar-sign",		'$'},
	{"percent-sign",		'%'},
	{"ampersand",		'&'},
	{"apostrophe",		'\''},
	{"left-parenthesis",	'('},
	{"right-parenthesis",	')'},
	{"asterisk",	'*'},
	{"plus-sign",	'+'},
	{"comma",	','},
	{"hyphen",	'-'},
	{"hyphen-minus",	'-'},
	{"period",	'.'},
	{"full-stop",	'.'},
	{"slash",	'/'},
	{"solidus",	'/'},
	{"zero",		'0'},
	{"one",		'1'},
	{"two",		'2'},
	{"three",	'3'},
	{"four",		'4'},
	{"five",		'5'},
	{"six",		'6'},
	{"seven",	'7'},
	{"eight",	'8'},
	{"nine",		'9'},
	{"colon",	':'},
	{"semicolon",	';'},
	{"less-than-sign",	'<'},
	{"equals-sign",		'='},
	{"greater-than-sign",	'>'},
	{"question-mark",	'?'},
	{"commercial-at",	'@'},
	{"left-square-bracket",	'['},
	{"backslash",		'\\'},
	{"reverse-solidus",	'\\'},
	{"right-square-bracket",	']'},
	{"circumflex",		'^'},
	{"circumflex-accent",	'^'},
	{"underscore",		'_'},
	{"low-line",		'_'},
	{"grave-accent",		'`'},
	{"left-brace",		'{'},
	{"left-curly-bracket",	'{'},
	{"vertical-line",	'|'},
	{"right-brace",		'}'},
	{"right-curly-bracket",	'}'},
	{"tilde",		'~'},
	{"DEL",	'\177'},
	{NULL,	0}
};

/* Unicode character-class tables */

typedef struct crange {
    chr start;
    chr end;











|





|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
/* 
 * regc_locale.c --
 *
 *	This file contains the Unicode locale specific regexp routines.
 *	This file is #included by regcomp.c.
 *
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: regc_locale.c,v 1.6.10.3 2002/08/20 20:25:24 das Exp $
 */

/* ASCII character-name table */

static struct cname {
    char *name;
    char code;
} cnames[] = {
    {"NUL",		'\0'},
    {"SOH",		'\001'},
    {"STX",		'\002'},
    {"ETX",		'\003'},
    {"EOT",		'\004'},
    {"ENQ",		'\005'},
    {"ACK",		'\006'},
    {"BEL",		'\007'},
    {"alert",		'\007'},
    {"BS",		'\010'},
    {"backspace",	'\b'},
    {"HT",		'\011'},
    {"tab",		'\t'},
    {"LF",		'\012'},
    {"newline",		'\n'},
    {"VT",		'\013'},
    {"vertical-tab",	'\v'},
    {"FF",		'\014'},
    {"form-feed",	'\f'},
    {"CR",		'\015'},
    {"carriage-return",	'\r'},
    {"SO",		'\016'},
    {"SI",		'\017'},
    {"DLE",		'\020'},
    {"DC1",		'\021'},
    {"DC2",		'\022'},
    {"DC3",		'\023'},
    {"DC4",		'\024'},
    {"NAK",		'\025'},
    {"SYN",		'\026'},
    {"ETB",		'\027'},
    {"CAN",		'\030'},
    {"EM",		'\031'},
    {"SUB",		'\032'},
    {"ESC",		'\033'},
    {"IS4",		'\034'},
    {"FS",		'\034'},
    {"IS3",		'\035'},
    {"GS",		'\035'},

    {"IS2",		'\036'},
    {"RS",		'\036'},
    {"IS1",		'\037'},
    {"US",		'\037'},
    {"space",		' '},
    {"exclamation-mark",'!'},
    {"quotation-mark",	'"'},
    {"number-sign",	'#'},
    {"dollar-sign",	'$'},
    {"percent-sign",	'%'},
    {"ampersand",	'&'},
    {"apostrophe",	'\''},
    {"left-parenthesis",'('},
    {"right-parenthesis", ')'},
    {"asterisk",	'*'},
    {"plus-sign",	'+'},
    {"comma",		','},
    {"hyphen",		'-'},
    {"hyphen-minus",	'-'},
    {"period",		'.'},
    {"full-stop",	'.'},
    {"slash",		'/'},
    {"solidus",		'/'},
    {"zero",		'0'},
    {"one",		'1'},
    {"two",		'2'},
    {"three",		'3'},
    {"four",		'4'},
    {"five",		'5'},
    {"six",		'6'},
    {"seven",		'7'},
    {"eight",		'8'},
    {"nine",		'9'},
    {"colon",		':'},
    {"semicolon",	';'},
    {"less-than-sign",	'<'},
    {"equals-sign",	'='},
    {"greater-than-sign", '>'},
    {"question-mark",	'?'},
    {"commercial-at",	'@'},
    {"left-square-bracket", '['},
    {"backslash",	'\\'},
    {"reverse-solidus",	'\\'},
    {"right-square-bracket", ']'},
    {"circumflex",	'^'},
    {"circumflex-accent", '^'},
    {"underscore",	'_'},
    {"low-line",	'_'},
    {"grave-accent",	'`'},
    {"left-brace",	'{'},
    {"left-curly-bracket", '{'},
    {"vertical-line",	'|'},
    {"right-brace",	'}'},
    {"right-curly-bracket", '}'},
    {"tilde",		'~'},
    {"DEL",		'\177'},
    {NULL,		0}
};

/* Unicode character-class tables */

typedef struct crange {
    chr start;
    chr end;
522
523
524
525
526
527
528
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

/*
 - nmcces - how many distinct MCCEs are there?
 ^ static int nmcces(struct vars *);
 */
static int
nmcces(v)
struct vars *v;
{



	return 0;
}

/*
 - nleaders - how many chrs can be first chrs of MCCEs?
 ^ static int nleaders(struct vars *);
 */
static int
nleaders(v)
struct vars *v;
{
	return 0;
}

/*
 - allmcces - return a cvec with all the MCCEs of the locale
 ^ static struct cvec *allmcces(struct vars *, struct cvec *);
 */
static struct cvec *
allmcces(v, cv)
struct vars *v;
struct cvec *cv;		/* this is supposed to have enough room */
{
	return clearcvec(cv);
}

/*
 - element - map collating-element name to celt
 ^ static celt element(struct vars *, chr *, chr *);
 */
static celt
element(v, startp, endp)
struct vars *v;
chr *startp;			/* points to start of name */
chr *endp;			/* points just past end of name */
{
	struct cname *cn;
	size_t len;
	Tcl_DString ds;
	CONST char *np;

	/* generic:  one-chr names stand for themselves */
	assert(startp < endp);
	len = endp - startp;
	if (len == 1)
		return *startp;


	NOTE(REG_ULOCALE);

	/* search table */
	Tcl_DStringInit(&ds);
	np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
	for (cn = cnames; cn->name != NULL; cn++)
		if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0)
			break;		/* NOTE BREAK OUT */


	Tcl_DStringFree(&ds);
	if (cn->name != NULL)
		return CHR(cn->code);


	/* couldn't find it */
	ERR(REG_ECOLLATE);
	return 0;
}

/*
 - range - supply cvec for a range, including legality check
 ^ static struct cvec *range(struct vars *, celt, celt, int);
 */
static struct cvec *
range(v, a, b, cases)
struct vars *v;
celt a;
celt b;				/* might equal a */
int cases;			/* case-independent? */
{
	int nchrs;
	struct cvec *cv;
	celt c, lc, uc, tc;

	if (a != b && !before(a, b)) {
		ERR(REG_ERANGE);
		return NULL;
	}

	if (!cases) {		/* easy version */
		cv = getcvec(v, 0, 1, 0);
		NOERRN();
		addrange(cv, a, b);
		return cv;
	}

	/*
	 * When case-independent, it's hard to decide when cvec ranges are
	 * usable, so for now at least, we won't try.  We allocate enough
	 * space for two case variants plus a little extra for the two
	 * title case variants.
	 */

	nchrs = (b - a + 1)*2 + 4;

	cv = getcvec(v, nchrs, 0, 0);
	NOERRN();

	for (c = a; c <= b; c++) {
		addchr(cv, c);
		lc = Tcl_UniCharToLower((chr)c);
		uc = Tcl_UniCharToUpper((chr)c);
		tc = Tcl_UniCharToTitle((chr)c);
		if (c != lc) {
			addchr(cv, lc);
		}
		if (c != uc) {
			addchr(cv, uc);
		}
		if (c != tc && tc != uc) {
			addchr(cv, tc);
		}
	}

	return cv;
}

/*
 - before - is celt x before celt y, for purposes of range legality?
 ^ static int before(celt, celt);
 */
static int			/* predicate */
before(x, y)
celt x;
celt y;
{
	/* trivial because no MCCEs */
	if (x < y)
		return 1;

	return 0;
}

/*
 - eclass - supply cvec for an equivalence class
 * Must include case counterparts on request.
 ^ static struct cvec *eclass(struct vars *, celt, int);
 */
static struct cvec *
eclass(v, c, cases)
struct vars *v;
celt c;

int cases;			/* all cases? */
{
	struct cvec *cv;

	/* crude fake equivalence class for testing */
	if ((v->cflags&REG_FAKE) && c == 'x') {
		cv = getcvec(v, 4, 0, 0);
		addchr(cv, (chr)'x');
		addchr(cv, (chr)'y');
		if (cases) {
			addchr(cv, (chr)'X');
			addchr(cv, (chr)'Y');
		}
		return cv;
	}

	/* otherwise, none */
	if (cases)
		return allcases(v, c);

	cv = getcvec(v, 1, 0, 0);
	assert(cv != NULL);
	addchr(cv, (chr)c);
	return cv;
}

/*
 - cclass - supply cvec for a character class
 * Must include case counterparts on request.
 ^ static struct cvec *cclass(struct vars *, chr *, chr *, int);
 */
static struct cvec *
cclass(v, startp, endp, cases)
struct vars *v;
chr *startp;			/* where the name starts */
chr *endp;			/* just past the end of the name */
int cases;			/* case-independent? */
{
    size_t len;
    struct cvec *cv = NULL;
    Tcl_DString ds;
    CONST char *np;
    char **namePtr;
    int i, index;







|

>
>
>
|








|

|








|
|

|








|
|
|

|
|
|
|

|
|
|
|
|
|
>
|

|
|
|
|
|
|
>
>
|
|
|
|
>
|
|
|








|
|
|
|

|
|
|

|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|

|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|






|

|
<

|
|
|
>
|









|
|
>
|

|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
>
|
|
|
|









|
|
|
|







522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666

667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728

/*
 - nmcces - how many distinct MCCEs are there?
 ^ static int nmcces(struct vars *);
 */
static int
nmcces(v)
    struct vars *v;			/* context */
{
    /*
     * No multi-character collating elements defined at the moment.
     */
    return 0;
}

/*
 - nleaders - how many chrs can be first chrs of MCCEs?
 ^ static int nleaders(struct vars *);
 */
static int
nleaders(v)
    struct vars *v;			/* context */
{
    return 0;
}

/*
 - allmcces - return a cvec with all the MCCEs of the locale
 ^ static struct cvec *allmcces(struct vars *, struct cvec *);
 */
static struct cvec *
allmcces(v, cv)
    struct vars *v;			/* context */
    struct cvec *cv;			/* this is supposed to have enough room */
{
    return clearcvec(cv);
}

/*
 - element - map collating-element name to celt
 ^ static celt element(struct vars *, chr *, chr *);
 */
static celt
element(v, startp, endp)
    struct vars *v;			/* context */
    chr *startp;			/* points to start of name */
    chr *endp;				/* points just past end of name */
{
    struct cname *cn;
    size_t len;
    Tcl_DString ds;
    CONST char *np;

    /* generic:  one-chr names stand for themselves */
    assert(startp < endp);
    len = endp - startp;
    if (len == 1) {
	return *startp;
    }

    NOTE(REG_ULOCALE);

    /* search table */
    Tcl_DStringInit(&ds);
    np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
    for (cn=cnames; cn->name!=NULL; cn++) {
	if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
	    break;			/* NOTE BREAK OUT */
	}
    }
    Tcl_DStringFree(&ds);
    if (cn->name != NULL) {
	return CHR(cn->code);
    }

    /* couldn't find it */
    ERR(REG_ECOLLATE);
    return 0;
}

/*
 - range - supply cvec for a range, including legality check
 ^ static struct cvec *range(struct vars *, celt, celt, int);
 */
static struct cvec *
range(v, a, b, cases)
    struct vars *v;			/* context */
    celt a;				/* range start */
    celt b;				/* range end, might equal a */
    int cases;				/* case-independent? */
{
    int nchrs;
    struct cvec *cv;
    celt c, lc, uc, tc;

    if (a != b && !before(a, b)) {
	ERR(REG_ERANGE);
	return NULL;
    }

    if (!cases) {			/* easy version */
	cv = getcvec(v, 0, 1, 0);
	NOERRN();
	addrange(cv, a, b);
	return cv;
    }

    /*
     * When case-independent, it's hard to decide when cvec ranges are
     * usable, so for now at least, we won't try.  We allocate enough
     * space for two case variants plus a little extra for the two
     * title case variants.
     */

    nchrs = (b - a + 1)*2 + 4;

    cv = getcvec(v, nchrs, 0, 0);
    NOERRN();

    for (c=a; c<=b; c++) {
	addchr(cv, c);
	lc = Tcl_UniCharToLower((chr)c);
	uc = Tcl_UniCharToUpper((chr)c);
	tc = Tcl_UniCharToTitle((chr)c);
	if (c != lc) {
	    addchr(cv, lc);
	}
	if (c != uc) {
	    addchr(cv, uc);
	}
	if (c != tc && tc != uc) {
	    addchr(cv, tc);
	}
    }

    return cv;
}

/*
 - before - is celt x before celt y, for purposes of range legality?
 ^ static int before(celt, celt);
 */
static int				/* predicate */
before(x, y)
    celt x, y;				/* collating elements */

{
    /* trivial because no MCCEs */
    if (x < y) {
	return 1;
    }
    return 0;
}

/*
 - eclass - supply cvec for an equivalence class
 * Must include case counterparts on request.
 ^ static struct cvec *eclass(struct vars *, celt, int);
 */
static struct cvec *
eclass(v, c, cases)
    struct vars *v;			/* context */
    celt c;				/* Collating element representing
					 * the equivalence class. */
    int cases;				/* all cases? */
{
    struct cvec *cv;

    /* crude fake equivalence class for testing */
    if ((v->cflags&REG_FAKE) && c == 'x') {
	cv = getcvec(v, 4, 0, 0);
	addchr(cv, (chr)'x');
	addchr(cv, (chr)'y');
	if (cases) {
	    addchr(cv, (chr)'X');
	    addchr(cv, (chr)'Y');
	}
	return cv;
    }

    /* otherwise, none */
    if (cases) {
	return allcases(v, c);
    }
    cv = getcvec(v, 1, 0, 0);
    assert(cv != NULL);
    addchr(cv, (chr)c);
    return cv;
}

/*
 - cclass - supply cvec for a character class
 * Must include case counterparts on request.
 ^ static struct cvec *cclass(struct vars *, chr *, chr *, int);
 */
static struct cvec *
cclass(v, startp, endp, cases)
    struct vars *v;			/* context */
    chr *startp;			/* where the name starts */
    chr *endp;				/* just past the end of the name */
    int cases;				/* case-independent? */
{
    size_t len;
    struct cvec *cv = NULL;
    Tcl_DString ds;
    CONST char *np;
    char **namePtr;
    int i, index;
751
752
753
754
755
756
757
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
    }

    /*
     * Map the name to the corresponding enumerated value.
     */

    index = -1;
    for (namePtr = classNames, i = 0; *namePtr != NULL; namePtr++, i++) {
	if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) {
	    index = i;
	    break;
	}
    }
    Tcl_DStringInit(&ds);
    if (index == -1) {
	ERR(REG_ECTYPE);
	return NULL;
    }
    
    /*
     * Now compute the character class contents.
     */

    switch((enum classes) index) {
	case CC_PRINT:
	case CC_ALNUM:
	    cv = getcvec(v, NUM_ALPHA_CHAR,
		    NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_ALPHA_CHAR; i++) {
		    addchr(cv, alphaCharTable[i]);
		}
		for (i = 0; i < NUM_ALPHA_RANGE; i++) {
		    addrange(cv, alphaRangeTable[i].start,
			     alphaRangeTable[i].end);
		}
		for (i = 0; i < NUM_DIGIT_RANGE; i++) {
		    addrange(cv, digitRangeTable[i].start,
			    digitRangeTable[i].end);
		}
	    }
	    break;
	case CC_ALPHA:
	    cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_ALPHA_RANGE; i++) {
		    addrange(cv, alphaRangeTable[i].start,
			     alphaRangeTable[i].end);
		}
		for (i = 0; i < NUM_ALPHA_CHAR; i++) {
		    addchr(cv, alphaCharTable[i]);
		}
	    }
	    break;
	case CC_ASCII:
	    cv = getcvec(v, 0, 1, 0);
	    if (cv) {
		addrange(cv, 0, 0x7f);
	    }
	    break;
	case CC_BLANK:
	    cv = getcvec(v, 2, 0, 0);
	    addchr(cv, '\t');
	    addchr(cv, ' ');
	    break;
	case CC_CNTRL:
	    cv = getcvec(v, 0, 2, 0);
	    addrange(cv, 0x0, 0x1f);
	    addrange(cv, 0x7f, 0x9f);
	    break;
	case CC_DIGIT:
	    cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0);
	    if (cv) {	
		for (i = 0; i < NUM_DIGIT_RANGE; i++) {
		    addrange(cv, digitRangeTable[i].start,
			    digitRangeTable[i].end);
		}
	    }
	    break;
	case CC_PUNCT:
	    cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_PUNCT_RANGE; i++) {
		    addrange(cv, punctRangeTable[i].start,
			     punctRangeTable[i].end);
		}
		for (i = 0; i < NUM_PUNCT_CHAR; i++) {
		    addchr(cv, punctCharTable[i]);
		}
	    }
	    break;
	case CC_XDIGIT:









	    cv = getcvec(v, 0, NUM_DIGIT_RANGE+2, 0);
	    if (cv) {	
		addrange(cv, '0', '9');
		addrange(cv, 'a', 'f');
		addrange(cv, 'A', 'F');
	    }
	    break;
	case CC_SPACE:
	    cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_SPACE_RANGE; i++) {
		    addrange(cv, spaceRangeTable[i].start,
			     spaceRangeTable[i].end);
		}
		for (i = 0; i < NUM_SPACE_CHAR; i++) {
		    addchr(cv, spaceCharTable[i]);
		}
	    }
	    break;
	case CC_LOWER:
	    cv  = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_LOWER_RANGE; i++) {
		    addrange(cv, lowerRangeTable[i].start,
			     lowerRangeTable[i].end);
		}
		for (i = 0; i < NUM_LOWER_CHAR; i++) {
		    addchr(cv, lowerCharTable[i]);
		}
	    }
	    break;
	case CC_UPPER:
	    cv  = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_UPPER_RANGE; i++) {
		    addrange(cv, upperRangeTable[i].start,
			     upperRangeTable[i].end);
		}
		for (i = 0; i < NUM_UPPER_CHAR; i++) {
		    addchr(cv, upperCharTable[i]);
		}
	    }
	    break;
	case CC_GRAPH:
	    cv  = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0);
	    if (cv) {
		for (i = 0; i < NUM_GRAPH_RANGE; i++) {
		    addrange(cv, graphRangeTable[i].start,
			     graphRangeTable[i].end);
		}
		for (i = 0; i < NUM_GRAPH_CHAR; i++) {
		    addchr(cv, graphCharTable[i]);
		}
	    }
	    break;
    }
    if (cv == NULL) {
	ERR(REG_ESPACE);
    }
    return cv;
}

/*
 - allcases - supply cvec for all case counterparts of a chr (including itself)
 * This is a shortcut, preferably an efficient one, for simple characters;
 * messy cases are done via range().
 ^ static struct cvec *allcases(struct vars *, pchr);
 */
static struct cvec *
allcases(v, pc)
struct vars *v;
pchr pc;
{
	struct cvec *cv;
	chr c = (chr)pc;
	chr lc, uc, tc;

	lc = Tcl_UniCharToLower((chr)c);
	uc = Tcl_UniCharToUpper((chr)c);
	tc = Tcl_UniCharToTitle((chr)c);

	if (tc != uc) {
	    cv = getcvec(v, 3, 0, 0);
	    addchr(cv, tc);
	} else {
	    cv = getcvec(v, 2, 0, 0);
	}
	addchr(cv, lc);
	if (lc != uc) {
	    addchr(cv, uc);
	}
	return cv;
}

/*
 - cmp - chr-substring compare
 * Backrefs need this.  It should preferably be efficient.
 * Note that it does not need to report anything except equal/unequal.
 * Note also that the length is exact, and the comparison should not
 * stop at embedded NULs!
 ^ static int cmp(CONST chr *, CONST chr *, size_t);
 */
static int			/* 0 for equal, nonzero for unequal */
cmp(x, y, len)
CONST chr *x;
CONST chr *y;
size_t len;			/* exact length of comparison */
{
	return memcmp(VS(x), VS(y), len*sizeof(chr));
}

/*
 - casecmp - case-independent chr-substring compare
 * REG_ICASE backrefs need this.  It should preferably be efficient.
 * Note that it does not need to report anything except equal/unequal.
 * Note also that the length is exact, and the comparison should not
 * stop at embedded NULs!
 ^ static int casecmp(CONST chr *, CONST chr *, size_t);
 */
static int			/* 0 for equal, nonzero for unequal */
casecmp(x, y, len)
CONST chr *x;
CONST chr *y;
size_t len;			/* exact length of comparison */
{
    for ( ; len > 0; len--, x++, y++)
	if ((*x != *y) && (Tcl_UniCharToLower(*x) != Tcl_UniCharToLower(*y)))
	    return 1;


    return 0;
}







|
















|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|















|
|

|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|










|

|
<
|

|










|

|
<
|

|
|

>
>


760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786

787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964

965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980

981
982
983
984
985
986
987
988
989
    }

    /*
     * Map the name to the corresponding enumerated value.
     */

    index = -1;
    for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) {
	if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) {
	    index = i;
	    break;
	}
    }
    Tcl_DStringInit(&ds);
    if (index == -1) {
	ERR(REG_ECTYPE);
	return NULL;
    }
    
    /*
     * Now compute the character class contents.
     */

    switch((enum classes) index) {
    case CC_PRINT:
    case CC_ALNUM:
	cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0);

	if (cv) {
	    for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
		addchr(cv, alphaCharTable[i]);
	    }
	    for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
		addrange(cv, alphaRangeTable[i].start,
			alphaRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
		addrange(cv, digitRangeTable[i].start,
			digitRangeTable[i].end);
	    }
	}
	break;
    case CC_ALPHA:
	cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0);
	if (cv) {
	    for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
		addrange(cv, alphaRangeTable[i].start,
			alphaRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
		addchr(cv, alphaCharTable[i]);
	    }
	}
	break;
    case CC_ASCII:
	cv = getcvec(v, 0, 1, 0);
	if (cv) {
	    addrange(cv, 0, 0x7f);
	}
	break;
    case CC_BLANK:
	cv = getcvec(v, 2, 0, 0);
	addchr(cv, '\t');
	addchr(cv, ' ');
	break;
    case CC_CNTRL:
	cv = getcvec(v, 0, 2, 0);
	addrange(cv, 0x0, 0x1f);
	addrange(cv, 0x7f, 0x9f);
	break;
    case CC_DIGIT:
	cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0);
	if (cv) {	
	    for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
		addrange(cv, digitRangeTable[i].start,
			digitRangeTable[i].end);
	    }
	}
	break;
    case CC_PUNCT:
	cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0);
	if (cv) {
	    for (i=0 ; i<NUM_PUNCT_RANGE ; i++) {
		addrange(cv, punctRangeTable[i].start,
			punctRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_PUNCT_CHAR ; i++) {
		addchr(cv, punctCharTable[i]);
	    }
	}
	break;
    case CC_XDIGIT:
	/*
	 * This is a 3 instead of (NUM_DIGIT_RANGE+2) because I've no
	 * idea how to define the digits 'a' through 'f' in
	 * non-western locales.  The concept is quite possibly non
	 * portable, or only used in contextx where the characters
	 * used would be the western ones anyway!  Whatever is
	 * actually the case, the number of ranges is fixed (until
	 * someone comes up with a better arrangement!)
	 */
	cv = getcvec(v, 0, 3, 0);
	if (cv) {	
	    addrange(cv, '0', '9');
	    addrange(cv, 'a', 'f');
	    addrange(cv, 'A', 'F');
	}
	break;
    case CC_SPACE:
	cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0);
	if (cv) {
	    for (i=0 ; i<NUM_SPACE_RANGE ; i++) {
		addrange(cv, spaceRangeTable[i].start,
			spaceRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
		addchr(cv, spaceCharTable[i]);
	    }
	}
	break;
    case CC_LOWER:
	cv  = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0);
	if (cv) {
	    for (i=0 ; i<NUM_LOWER_RANGE ; i++) {
		addrange(cv, lowerRangeTable[i].start,
			lowerRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_LOWER_CHAR ; i++) {
		addchr(cv, lowerCharTable[i]);
	    }
	}
	break;
    case CC_UPPER:
	cv  = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0);
	if (cv) {
	    for (i=0 ; i<NUM_UPPER_RANGE ; i++) {
		addrange(cv, upperRangeTable[i].start,
			upperRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
		addchr(cv, upperCharTable[i]);
	    }
	}
	break;
    case CC_GRAPH:
	cv  = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0);
	if (cv) {
	    for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
		addrange(cv, graphRangeTable[i].start,
			graphRangeTable[i].end);
	    }
	    for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
		addchr(cv, graphCharTable[i]);
	    }
	}
	break;
    }
    if (cv == NULL) {
	ERR(REG_ESPACE);
    }
    return cv;
}

/*
 - allcases - supply cvec for all case counterparts of a chr (including itself)
 * This is a shortcut, preferably an efficient one, for simple characters;
 * messy cases are done via range().
 ^ static struct cvec *allcases(struct vars *, pchr);
 */
static struct cvec *
allcases(v, pc)
    struct vars *v;			/* context */
    pchr pc;				/* character to get case equivs of */
{
    struct cvec *cv;
    chr c = (chr)pc;
    chr lc, uc, tc;

    lc = Tcl_UniCharToLower((chr)c);
    uc = Tcl_UniCharToUpper((chr)c);
    tc = Tcl_UniCharToTitle((chr)c);

    if (tc != uc) {
	cv = getcvec(v, 3, 0, 0);
	addchr(cv, tc);
    } else {
	cv = getcvec(v, 2, 0, 0);
    }
    addchr(cv, lc);
    if (lc != uc) {
	addchr(cv, uc);
    }
    return cv;
}

/*
 - cmp - chr-substring compare
 * Backrefs need this.  It should preferably be efficient.
 * Note that it does not need to report anything except equal/unequal.
 * Note also that the length is exact, and the comparison should not
 * stop at embedded NULs!
 ^ static int cmp(CONST chr *, CONST chr *, size_t);
 */
static int				/* 0 for equal, nonzero for unequal */
cmp(x, y, len)
    CONST chr *x, *y;			/* strings to compare */

    size_t len;				/* exact length of comparison */
{
    return memcmp(VS(x), VS(y), len*sizeof(chr));
}

/*
 - casecmp - case-independent chr-substring compare
 * REG_ICASE backrefs need this.  It should preferably be efficient.
 * Note that it does not need to report anything except equal/unequal.
 * Note also that the length is exact, and the comparison should not
 * stop at embedded NULs!
 ^ static int casecmp(CONST chr *, CONST chr *, size_t);
 */
static int				/* 0 for equal, nonzero for unequal */
casecmp(x, y, len)
    CONST chr *x, *y;			/* strings to compare */

    size_t len;				/* exact length of comparison */
{
    for (; len > 0; len--, x++, y++) {
	if ((*x!=*y) && (Tcl_UniCharToLower(*x) != Tcl_UniCharToLower(*y))) {
	    return 1;
	}
    }
    return 0;
}
Changes to generic/tcl.decls.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
# tcl.decls --
#
#	This file contains the declarations for all supported public
#	functions that are exported by the Tcl library via the stubs table.
#	This file is used to generate the tclDecls.h, tclPlatDecls.h,
#	tclStub.c, and tclPlatStub.c files.
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tcl.decls,v 1.63.2.3 2002/06/10 05:33:09 wolfsuit Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private

interface tcl
hooks {tclPlat tclInt tclIntPlat}

# Declare each of the functions in the public Tcl interface.  Note that
# the an index should never be reused for a different function in order
# to preserve backwards compatibility.

declare 0 generic {
    int Tcl_PkgProvideEx(Tcl_Interp* interp, CONST char* name,
	    CONST char* version, ClientData clientData)
}
declare 1 generic {
    CONST char * Tcl_PkgRequireEx(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 2 generic {
    void Tcl_Panic(CONST char *format, ...)
}
declare 3 generic {
    char * Tcl_Alloc(unsigned int size)













|




















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
# tcl.decls --
#
#	This file contains the declarations for all supported public
#	functions that are exported by the Tcl library via the stubs table.
#	This file is used to generate the tclDecls.h, tclPlatDecls.h,
#	tclStub.c, and tclPlatStub.c files.
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tcl.decls,v 1.63.2.4 2002/08/20 20:25:24 das Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private

interface tcl
hooks {tclPlat tclInt tclIntPlat}

# Declare each of the functions in the public Tcl interface.  Note that
# the an index should never be reused for a different function in order
# to preserve backwards compatibility.

declare 0 generic {
    int Tcl_PkgProvideEx(Tcl_Interp* interp, CONST char* name,
	    CONST char* version, ClientData clientData)
}
declare 1 generic {
    CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 2 generic {
    void Tcl_Panic(CONST char *format, ...)
}
declare 3 generic {
    char * Tcl_Alloc(unsigned int size)
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
declare 80 generic {
    void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
declare 81 generic {
    int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 generic {
    int Tcl_CommandComplete(char *cmd)
}
declare 83 generic {
    char * Tcl_Concat(int argc, CONST84 char * CONST *argv)
}
declare 84 generic {
    int Tcl_ConvertElement(CONST char *src, char *dst, int flags)
}
declare 85 generic {
    int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst,
	    int flags)
}
declare 86 generic {
    int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd,
	    Tcl_Interp *target, CONST char *targetCmd, int argc,
	    char * CONST *argv)
}
declare 87 generic {
    int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd,
	    Tcl_Interp *target, CONST char *targetCmd, int objc,
	    Tcl_Obj *CONST objv[])
}
declare 88 generic {







|














|







299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
declare 80 generic {
    void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
declare 81 generic {
    int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 generic {
    int Tcl_CommandComplete(CONST char *cmd)
}
declare 83 generic {
    char * Tcl_Concat(int argc, CONST84 char * CONST *argv)
}
declare 84 generic {
    int Tcl_ConvertElement(CONST char *src, char *dst, int flags)
}
declare 85 generic {
    int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst,
	    int flags)
}
declare 86 generic {
    int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd,
	    Tcl_Interp *target, CONST char *targetCmd, int argc,
	    CONST84 char * CONST *argv)
}
declare 87 generic {
    int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd,
	    Tcl_Interp *target, CONST char *targetCmd, int objc,
	    Tcl_Obj *CONST objv[])
}
declare 88 generic {
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
declare 125 generic {
    void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 generic {
    int Tcl_Eof(Tcl_Channel chan)
}
declare 127 generic {
    CONST char * Tcl_ErrnoId(void)
}
declare 128 generic {
    CONST char * Tcl_ErrnoMsg(int err)
}
declare 129 generic {
    int Tcl_Eval(Tcl_Interp *interp, char *string)
}
# This is obsolete, use Tcl_FSEvalFile
declare 130 generic {
    int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
}
declare 131 generic {
    int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)







|


|


|







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
declare 125 generic {
    void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 generic {
    int Tcl_Eof(Tcl_Channel chan)
}
declare 127 generic {
    CONST84_RETURN char * Tcl_ErrnoId(void)
}
declare 128 generic {
    CONST84_RETURN char * Tcl_ErrnoMsg(int err)
}
declare 129 generic {
    int Tcl_Eval(Tcl_Interp *interp, CONST char *string)
}
# This is obsolete, use Tcl_FSEvalFile
declare 130 generic {
    int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
}
declare 131 generic {
    int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
}
declare 147 generic {
    void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 generic {
    int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd,
	    Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
	    int *argcPtr, char ***argvPtr)
}
declare 149 generic {
    int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd,
	    Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
	    int *objcPtr, Tcl_Obj ***objv)
}
declare 150 generic {







|







526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
}
declare 147 generic {
    void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 generic {
    int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd,
	    Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
	    int *argcPtr, CONST84 char ***argvPtr)
}
declare 149 generic {
    int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd,
	    Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
	    int *objcPtr, Tcl_Obj ***objv)
}
declare 150 generic {
555
556
557
558
559
560
561
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
declare 154 generic {
    ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 generic {
    int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 generic {
    CONST char * Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 generic {
    int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
	    CONST char *optionName, Tcl_DString *dsPtr)
}
declare 158 generic {
    Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 generic {
    int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
	    Tcl_CmdInfo *infoPtr)
}
declare 160 generic {
    CONST char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command)

}
declare 161 generic {
    int Tcl_GetErrno(void)
}
declare 162 generic {
    CONST char * Tcl_GetHostName(void)
}
declare 163 generic {
    int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
}
declare 164 generic {
    Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp)
}







|













|
>





|







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
declare 154 generic {
    ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 generic {
    int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 generic {
    CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 generic {
    int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
	    CONST char *optionName, Tcl_DString *dsPtr)
}
declare 158 generic {
    Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 generic {
    int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
	    Tcl_CmdInfo *infoPtr)
}
declare 160 generic {
    CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
	    Tcl_Command command)
}
declare 161 generic {
    int Tcl_GetErrno(void)
}
declare 162 generic {
    CONST84_RETURN char * Tcl_GetHostName(void)
}
declare 163 generic {
    int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
}
declare 164 generic {
    Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp)
}
618
619
620
621
622
623
624
625
626
627
628

629
630
631
632
633
634
635
636
637
638
639
640
641
642
declare 172 generic {
    Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName)
}
declare 173 generic {
    Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 generic {
    CONST char * Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 generic {
    CONST char * Tcl_GetVar(Tcl_Interp *interp, char *varName, int flags)

}
declare 176 generic {
    CONST char * Tcl_GetVar2(Tcl_Interp *interp, char *part1, CONST char *part2,
	    int flags)
}
declare 177 generic {
    int Tcl_GlobalEval(Tcl_Interp *interp, char *command)
}
declare 178 generic {
    int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 generic {
    int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName,
	    CONST char *hiddenCmdToken)







|


|
>


|
|


|







619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
declare 172 generic {
    Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName)
}
declare 173 generic {
    Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 generic {
    CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 generic {
    CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, CONST char *varName,
	    int flags)
}
declare 176 generic {
    CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, CONST char *part1,
	    CONST char *part2, int flags)
}
declare 177 generic {
    int Tcl_GlobalEval(Tcl_Interp *interp, CONST char *command)
}
declare 178 generic {
    int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 generic {
    int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName,
	    CONST char *hiddenCmdToken)
661
662
663
664
665
666
667
668

669
670
671
672
673
674
675
}
# Obsolete, use Tcl_FSJoinPath
declare 186 generic {
    char * Tcl_JoinPath(int argc, CONST84 char * CONST *argv,
	    Tcl_DString *resultPtr)
}
declare 187 generic {
    int Tcl_LinkVar(Tcl_Interp *interp, char *varName, char *addr, int type)

}

# This slot is reserved for use by the plus patch:
#  declare 188 generic {
#      Tcl_MainLoop
#  }








|
>







663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
}
# Obsolete, use Tcl_FSJoinPath
declare 186 generic {
    char * Tcl_JoinPath(int argc, CONST84 char * CONST *argv,
	    Tcl_DString *resultPtr)
}
declare 187 generic {
    int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, char *addr,
	    int type)
}

# This slot is reserved for use by the plus patch:
#  declare 188 generic {
#      Tcl_MainLoop
#  }

723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
declare 202 generic {
    void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 generic {
    int Tcl_PutEnv(CONST char *string)
}
declare 204 generic {
    CONST char * Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 generic {
    void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
declare 206 generic {
    int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
}







|







726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
declare 202 generic {
    void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 generic {
    int Tcl_PutEnv(CONST char *string)
}
declare 204 generic {
    CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 generic {
    void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
declare 206 generic {
    int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
}
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
declare 235 generic {
    void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 generic {
    void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 generic {
    CONST char * Tcl_SetVar(Tcl_Interp *interp, char *varName,
	    CONST char *newValue, int flags)
}
declare 238 generic {
    CONST char * Tcl_SetVar2(Tcl_Interp *interp, char *part1, CONST char *part2,
	    CONST char *newValue, int flags)
}
declare 239 generic {
    CONST char * Tcl_SignalId(int sig)
}
declare 240 generic {
    CONST char * Tcl_SignalMsg(int sig)
}
declare 241 generic {
    void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 generic {
    int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr,
	    CONST84 char ***argvPtr)







|



|
|


|


|







833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
declare 235 generic {
    void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 generic {
    void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 generic {
    CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, CONST char *varName,
	    CONST char *newValue, int flags)
}
declare 238 generic {
    CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, CONST char *part1,
	    CONST char *part2, CONST char *newValue, int flags)
}
declare 239 generic {
    CONST84_RETURN char * Tcl_SignalId(int sig)
}
declare 240 generic {
    CONST84_RETURN char * Tcl_SignalMsg(int sig)
}
declare 241 generic {
    void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 generic {
    int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr,
	    CONST84 char ***argvPtr)
866
867
868
869
870
871
872
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
    int Tcl_StringMatch(CONST char *str, CONST char *pattern)
}
# Obsolete
declare 246 generic {
    int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 generic {
    int Tcl_TraceVar(Tcl_Interp *interp, char *varName, int flags,
	    Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 248 generic {
    int Tcl_TraceVar2(Tcl_Interp *interp, char *part1, CONST char *part2,
	    int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 249 generic {
    char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name,
	    Tcl_DString *bufferPtr)
}
declare 250 generic {
    int Tcl_Ungets(Tcl_Channel chan, CONST char *str, int len, int atHead)
}
declare 251 generic {
    void Tcl_UnlinkVar(Tcl_Interp *interp, char *varName)
}
declare 252 generic {
    int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 253 generic {
    int Tcl_UnsetVar(Tcl_Interp *interp, char *varName, int flags)
}
declare 254 generic {
    int Tcl_UnsetVar2(Tcl_Interp *interp, char *part1, CONST char *part2,
	    int flags)
}
declare 255 generic {
    void Tcl_UntraceVar(Tcl_Interp *interp, char *varName, int flags,
	    Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 256 generic {
    void Tcl_UntraceVar2(Tcl_Interp *interp, char *part1, CONST char *part2,
	    int flags, Tcl_VarTraceProc *proc, ClientData clientData)

}
declare 257 generic {
    void Tcl_UpdateLinkedVar(Tcl_Interp *interp, char *varName)
}
declare 258 generic {
    int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName, char *varName,
	    CONST char *localName, int flags)
}
declare 259 generic {
    int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, char *part1,
	    CONST char *part2, CONST char *localName, int flags)
}
declare 260 generic {
    int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 261 generic {
    ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, char *varName,
	    int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
declare 262 generic {
    ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, char *part1,
	    CONST char *part2, int flags, Tcl_VarTraceProc *procPtr,
	    ClientData prevClientData)
}
declare 263 generic {
    int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen)
}
declare 264 generic {







|



|










|





|


|



|



|
|
>


|


|
|


|






|



|







869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
    int Tcl_StringMatch(CONST char *str, CONST char *pattern)
}
# Obsolete
declare 246 generic {
    int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 generic {
    int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
	    Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 248 generic {
    int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
	    int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 249 generic {
    char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name,
	    Tcl_DString *bufferPtr)
}
declare 250 generic {
    int Tcl_Ungets(Tcl_Channel chan, CONST char *str, int len, int atHead)
}
declare 251 generic {
    void Tcl_UnlinkVar(Tcl_Interp *interp, CONST char *varName)
}
declare 252 generic {
    int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 253 generic {
    int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName, int flags)
}
declare 254 generic {
    int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
	    int flags)
}
declare 255 generic {
    void Tcl_UntraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
	    Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 256 generic {
    void Tcl_UntraceVar2(Tcl_Interp *interp, CONST char *part1,
	    CONST char *part2, int flags, Tcl_VarTraceProc *proc,
	    ClientData clientData)
}
declare 257 generic {
    void Tcl_UpdateLinkedVar(Tcl_Interp *interp, CONST char *varName)
}
declare 258 generic {
    int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName,
	    CONST char *varName, CONST char *localName, int flags)
}
declare 259 generic {
    int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, CONST char *part1,
	    CONST char *part2, CONST char *localName, int flags)
}
declare 260 generic {
    int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 261 generic {
    ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, CONST char *varName,
	    int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
declare 262 generic {
    ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, CONST char *part1,
	    CONST char *part2, int flags, Tcl_VarTraceProc *procPtr,
	    ClientData prevClientData)
}
declare 263 generic {
    int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen)
}
declare 264 generic {
945
946
947
948
949
950
951
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
declare 267 generic {
    void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
declare 268 generic {
    void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
    CONST char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
    CONST char * Tcl_ParseVar(Tcl_Interp *interp, char *str, char **termPtr)

}
declare 271 generic {
    CONST char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact)
}
declare 272 generic {
    CONST char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 273 generic {
    int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name, 
	    CONST char *version)
}
declare 274 generic {
    CONST char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name, 
	    CONST char *version, int exact)
}
declare 275 generic {
    void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
declare 276 generic {
    int  Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)







|


|
>


|



|







|







949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
declare 267 generic {
    void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
declare 268 generic {
    void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
    CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
    CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *str,
	    CONST84 char **termPtr)
}
declare 271 generic {
    CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact)
}
declare 272 generic {
    CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name,
	    CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 273 generic {
    int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name, 
	    CONST char *version)
}
declare 274 generic {
    CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name, 
	    CONST char *version, int exact)
}
declare 275 generic {
    void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
declare 276 generic {
    int  Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
1038
1039
1040
1041
1042
1043
1044
1045

1046
1047
1048
1049
1050
1051
1052
declare 289 generic {
    void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 290 generic {
    void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 generic {
    int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags)

}
declare 292 generic {
    int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
	    int flags)
}
declare 293 generic {
    int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)







|
>







1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
declare 289 generic {
    void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 290 generic {
    void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 generic {
    int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script, int numBytes,
	    int flags)
}
declare 292 generic {
    int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
	    int flags)
}
declare 293 generic {
    int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
declare 300 generic {
    Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 generic {
    Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 302 generic {
    CONST char * Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 generic {
    void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 generic {
    int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CONST VOID *tablePtr, int offset, CONST char *msg, int flags,
	    int *indexPtr)
}
declare 305 generic {
    VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 generic {
    Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, CONST char *part2,
	    int flags)
}
declare 307 generic {
    ClientData Tcl_InitNotifier(void)
}
declare 308 generic {
    void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}







|













|
|







1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
declare 300 generic {
    Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 generic {
    Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 302 generic {
    CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 generic {
    void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 generic {
    int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CONST VOID *tablePtr, int offset, CONST char *msg, int flags,
	    int *indexPtr)
}
declare 305 generic {
    VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 generic {
    Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1,
	    CONST char *part2, int flags)
}
declare 307 generic {
    ClientData Tcl_InitNotifier(void)
}
declare 308 generic {
    void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
declare 315 generic {
    void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 generic {
    int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 317 generic {
    Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, CONST char *part2,
	    Tcl_Obj *newValuePtr, int flags)
}
declare 318 generic {
    void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 generic {
    void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr,
	    Tcl_QueuePosition position)







|
|







1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
declare 315 generic {
    void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 generic {
    int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 317 generic {
    Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1, 
            CONST char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 generic {
    void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 generic {
    void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr,
	    Tcl_QueuePosition position)
1152
1153
1154
1155
1156
1157
1158
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
declare 323 generic {
    Tcl_UniChar Tcl_UniCharToUpper(int ch)
}
declare 324 generic {
    int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
    CONST char * Tcl_UtfAtIndex(CONST char *src, int index)
}
declare 326 generic {
    int Tcl_UtfCharComplete(CONST char *src, int len)
}
declare 327 generic {
    int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
}
declare 328 generic {
    CONST char * Tcl_UtfFindFirst(CONST char *src, int ch)
}
declare 329 generic {
    CONST char * Tcl_UtfFindLast(CONST char *src, int ch)
}
declare 330 generic {
    CONST char * Tcl_UtfNext(CONST char *src)
}
declare 331 generic {
    CONST char * Tcl_UtfPrev(CONST char *src, CONST char *start)
}
declare 332 generic {
    int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
	    CONST char *src, int srcLen, int flags,
	    Tcl_EncodingState *statePtr, char *dst, int dstLen,
	    int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}







|








|


|


|


|







1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
declare 323 generic {
    Tcl_UniChar Tcl_UniCharToUpper(int ch)
}
declare 324 generic {
    int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
    CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index)
}
declare 326 generic {
    int Tcl_UtfCharComplete(CONST char *src, int len)
}
declare 327 generic {
    int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
}
declare 328 generic {
    CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch)
}
declare 329 generic {
    CONST84_RETURN char * Tcl_UtfFindLast(CONST char *src, int ch)
}
declare 330 generic {
    CONST84_RETURN char * Tcl_UtfNext(CONST char *src)
}
declare 331 generic {
    CONST84_RETURN char * Tcl_UtfPrev(CONST char *src, CONST char *start)
}
declare 332 generic {
    int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
	    CONST char *src, int srcLen, int flags,
	    Tcl_EncodingState *statePtr, char *dst, int dstLen,
	    int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
declare 339 generic {
    int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 generic {
    char * Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 generic {
    CONST char * Tcl_GetDefaultEncodingDir(void)
}
declare 342 generic {
    void Tcl_SetDefaultEncodingDir(CONST char *path)
}
declare 343 generic {
    void Tcl_AlertNotifier(ClientData clientData)
}







|







1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
declare 339 generic {
    int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 generic {
    char * Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 generic {
    CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void)
}
declare 342 generic {
    void Tcl_SetDefaultEncodingDir(CONST char *path)
}
declare 343 generic {
    void Tcl_AlertNotifier(ClientData clientData)
}
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288

1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
    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, char *string,
	    int numBytes, Tcl_Parse *parsePtr, int append, char **termPtr)
}
declare 361 generic {
    int Tcl_ParseCommand(Tcl_Interp *interp, char *string, int numBytes,
	    int nested, Tcl_Parse *parsePtr)
}
declare 362 generic {
    int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes,
	    Tcl_Parse *parsePtr)	 
}
declare 363 generic {
    int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes,
	    Tcl_Parse *parsePtr, int append, char **termPtr)

}
declare 364 generic {
    int Tcl_ParseVarName(Tcl_Interp *interp, char *string, int numBytes,
	    Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 generic {
    char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}







|
|


|



|



|
|
>


|







1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
    void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 generic {
    void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
	    CONST char *command, int length)
}
declare 360 generic {
    int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *string, int numBytes,
	    Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
declare 361 generic {
    int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *string, int numBytes,
	    int nested, Tcl_Parse *parsePtr)
}
declare 362 generic {
    int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *string, int numBytes,
	    Tcl_Parse *parsePtr)	 
}
declare 363 generic {
    int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *string,
	    int numBytes, Tcl_Parse *parsePtr, int append,
	    CONST84 char **termPtr)
}
declare 364 generic {
    int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *string, int numBytes,
	    Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 generic {
    char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
declare 396 generic {
    Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 generic {
    int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 generic {
    CONST char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr)
}
declare 399 generic {
    Tcl_ChannelTypeVersion Tcl_ChannelVersion(Tcl_ChannelType *chanTypePtr)
}
declare 400 generic {
    Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType
	    *chanTypePtr)







|







1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
declare 396 generic {
    Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 generic {
    int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 generic {
    CONST84_RETURN char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr)
}
declare 399 generic {
    Tcl_ChannelTypeVersion Tcl_ChannelVersion(Tcl_ChannelType *chanTypePtr)
}
declare 400 generic {
    Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType
	    *chanTypePtr)
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
    int	Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
}
declare 444 generic {
    int	Tcl_FSLoadFile(Tcl_Interp * interp,
	    Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2,
	    Tcl_PackageInitProc ** proc1Ptr,
	    Tcl_PackageInitProc ** proc2Ptr,
	    ClientData * clientDataPtr,
	    Tcl_FSUnloadFileProc **unloadProcPtr)
}
declare 445 generic {
    int	Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result,
	    Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
}
declare 446 generic {
    Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr)
}
declare 447 generic {
    int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
	    int recursive, Tcl_Obj **errorPtr)
}
declare 448 generic {
    int	Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)







|







|







1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
    int	Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
}
declare 444 generic {
    int	Tcl_FSLoadFile(Tcl_Interp * interp,
	    Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2,
	    Tcl_PackageInitProc ** proc1Ptr,
	    Tcl_PackageInitProc ** proc2Ptr,
	    Tcl_LoadHandle * handlePtr,
	    Tcl_FSUnloadFileProc **unloadProcPtr)
}
declare 445 generic {
    int	Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result,
	    Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
}
declare 446 generic {
    Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
}
declare 447 generic {
    int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
	    int recursive, Tcl_Obj **errorPtr)
}
declare 448 generic {
    int	Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
declare 466 generic {
    Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
}
declare 467 generic {
    int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 generic {
    Tcl_Obj* Tcl_FSNewNativePath(Tcl_Obj* fromFilesystem,
	    ClientData clientData)
}
declare 469 generic {
    CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr)
}
declare 470 generic {
    Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr)







|







1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
declare 466 generic {
    Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
}
declare 467 generic {
    int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 generic {
    Tcl_Obj* Tcl_FSNewNativePath(Tcl_Filesystem* fromFilesystem,
	    ClientData clientData)
}
declare 469 generic {
    CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr)
}
declare 470 generic {
    Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr)
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
    int strcasecmp(CONST char *s1, CONST char *s2)
}

##################
# Mac OS X declarations
#

declare 1 macosx {
    int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
        char *bundleName,
	int hasResourceFile,
	int maxPathLen,
        char *libraryPath)
}












|

|
|
|
|

<
<
<
<
<
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835





    int strcasecmp(CONST char *s1, CONST char *s2)
}

##################
# Mac OS X declarations
#

declare 0 macosx {
    int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
	    CONST char *bundleName,
	    int hasResourceFile,
	    int maxPathLen,
	    char *libraryPath)
}





Changes to generic/tcl.h.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.103.2.3 2002/06/10 05:33:09 wolfsuit Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tcl.h,v 1.103.2.4 2002/08/20 20:25:24 das Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
40
41
42
43
44
45
46
47
48
49
50
51
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
 * and update the version numbers:
 *
 * library/init.tcl	(only if Major.minor changes, not patchlevel) 1 LOC
 * unix/configure.in	(2 LOC Major, 2 LOC minor, 1 LOC patch)
 * win/configure.in	(as above)
 * win/tcl.m4		(not patchlevel)
 * win/makefile.vc	(not patchlevel) 2 LOC
 * library/reg/pkgIndex.tcl	(not patchlevel, for tclregNN.dll)
 * library/dde/pkgIndex.tcl	(not patchlevel, for tclddeNN.dll)
 * README		(sections 0 and 2)
 * mac/README		(2 LOC, not patchlevel)
 * win/README.binary	(sections 0-4)
 * win/README		(not patchlevel) (sections 0 and 2)
 * unix/README		(not patchlevel) (part (h))
 * unix/tcl.spec	(2 LOC Major/Minor, 1 LOC patch)
 * tests/basic.test	(1 LOC M/M)
 * tools/tcl.hpj.in	(not patchlevel, for windows installer)
 * tools/tcl.wse.in	(for windows installer)
 * tools/tclSplash.bmp	(not patchlevel)
 */
#define TCL_MAJOR_VERSION   8
#define TCL_MINOR_VERSION   4
#define TCL_RELEASE_LEVEL   TCL_ALPHA_RELEASE
#define TCL_RELEASE_SERIAL  5

#define TCL_VERSION	    "8.4"
#define TCL_PATCH_LEVEL	    "8.4a5"

/* 
 * A special definition used to allow this header file to be included 
 * in resource files so that they can get obtain version information from
 * this file.  Resource compilers don't like all the C stuff, like typedefs
 * and procedure declarations, that occur below.
 */

#ifndef RESOURCE_INCLUDED

/*
 * The following definitions set up the proper options for Windows
 * compilers.  We use this method because there is no autoconf equivalent.
 */

#ifndef __WIN32__
#   if defined(_WIN32) || defined(WIN32) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__BORLANDC__)
#	define __WIN32__
#	ifndef WIN32
#	    define WIN32
#	endif
#   endif
#endif




#ifdef __WIN32__
#   ifndef STRICT
#	define STRICT
#   endif
#   ifndef USE_PROTOTYPE
#	define USE_PROTOTYPE 1
#   endif
#   ifndef HAS_STDARG
#	define HAS_STDARG 1
#   endif
#   ifndef USE_PROTOTYPE
#	define USE_PROTOTYPE 1
#   endif

#endif /* __WIN32__ */

/*
 * The following definitions set up the proper options for Macintosh
 * compilers.  We use this method because there is no autoconf equivalent.
 */

#ifdef MAC_TCL
#include <ConditionalMacros.h>
#   ifndef HAS_STDARG
#	define HAS_STDARG 1
#   endif
#   ifndef USE_TCLALLOC
#	define USE_TCLALLOC 1
#   endif
#   ifndef NO_STRERROR
#	define NO_STRERROR 1
#   endif
#   define INLINE 
#endif


/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */

#define VERBATIM(x) x
#ifdef _MSC_VER
# define STRINGIFY(x) STRINGIFY1(x)
# define STRINGIFY1(x) #x
# define JOIN(a,b) JOIN1(a,b)
# define JOIN1(a,b) a##b
#else
# ifdef RESOURCE_INCLUDED
#  define STRINGIFY(x) STRINGIFY1(x)
#  define STRINGIFY1(x) #x
#  define JOIN(a,b) JOIN1(a,b)
#  define JOIN1(a,b) a##b
# else
#  ifdef __STDC__

#   define STRINGIFY(x) #x

#   define JOIN(a,b) a##b



#  else
#   define STRINGIFY(x) "x"
#   define JOIN(a,b) VERBATIM(a)VERBATIM(b)

#  endif





# endif
#endif

/*
 * 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;







<
<




<

|






|
|


|
<
<
<
<
<
<
<
<
<















>
>
>




<
<
<
<
<
<
<
<
<
<









<
<
<








>





|
<
<
|
|
<
<
|
|
<
<


|
|
>
|
>
|
>
>
>
|
|
|
>
|
>
>
>
>
>
|
|








40
41
42
43
44
45
46


47
48
49
50

51
52
53
54
55
56
57
58
59
60
61
62
63









64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85










86
87
88
89
90
91
92
93
94



95
96
97
98
99
100
101
102
103
104
105
106
107
108
109


110
111


112
113


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
 * and update the version numbers:
 *
 * library/init.tcl	(only if Major.minor changes, not patchlevel) 1 LOC
 * unix/configure.in	(2 LOC Major, 2 LOC minor, 1 LOC patch)
 * win/configure.in	(as above)
 * win/tcl.m4		(not patchlevel)
 * win/makefile.vc	(not patchlevel) 2 LOC


 * README		(sections 0 and 2)
 * mac/README		(2 LOC, not patchlevel)
 * win/README.binary	(sections 0-4)
 * win/README		(not patchlevel) (sections 0 and 2)

 * unix/tcl.spec	(2 LOC Major/Minor, 1 LOC patch)
 * tests/basic.test	(1 LOC M/M, not patchlevel)
 * tools/tcl.hpj.in	(not patchlevel, for windows installer)
 * tools/tcl.wse.in	(for windows installer)
 * tools/tclSplash.bmp	(not patchlevel)
 */
#define TCL_MAJOR_VERSION   8
#define TCL_MINOR_VERSION   4
#define TCL_RELEASE_LEVEL   TCL_BETA_RELEASE
#define TCL_RELEASE_SERIAL  3

#define TCL_VERSION	    "8.4"
#define TCL_PATCH_LEVEL	    "8.4b3"










/*
 * The following definitions set up the proper options for Windows
 * compilers.  We use this method because there is no autoconf equivalent.
 */

#ifndef __WIN32__
#   if defined(_WIN32) || defined(WIN32) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__BORLANDC__)
#	define __WIN32__
#	ifndef WIN32
#	    define WIN32
#	endif
#   endif
#endif

/*
 * STRICT: See MSDN Article Q83456
 */
#ifdef __WIN32__
#   ifndef STRICT
#	define STRICT
#   endif










#endif /* __WIN32__ */

/*
 * The following definitions set up the proper options for Macintosh
 * compilers.  We use this method because there is no autoconf equivalent.
 */

#ifdef MAC_TCL
#include <ConditionalMacros.h>



#   ifndef USE_TCLALLOC
#	define USE_TCLALLOC 1
#   endif
#   ifndef NO_STRERROR
#	define NO_STRERROR 1
#   endif
#   define INLINE 
#endif


/*
 * Utility macros: STRINGIFY takes an argument and wraps it in "" (double
 * quotation marks), JOIN joins two arguments.
 */
#ifndef STRINGIFY


#  define STRINGIFY(x) STRINGIFY1(x)
#  define STRINGIFY1(x) #x


#endif
#ifndef JOIN


#  define JOIN(a,b) JOIN1(a,b)
#  define JOIN1(a,b) a##b
#endif

/* 
 * A special definition used to allow this header file to be included
 * from windows resource files so that they can obtain version
 * information.  RC_INVOKED is defined by default by the RC tool.
 * Resource compilers don't like all the C stuff, like typedefs and
 * procedure declarations, that occur below, so block them out.
 */

#ifndef RC_INVOKED

/* 
 * A special definition for Macintosh used to allow this header file
 * to be included in resource files so that they can get obtain
 * version information from this file.  Resource compilers don't like
 * all the C stuff, like typedefs and procedure declarations, that
 * occur below.  
*/

#ifndef RESOURCE_INCLUDED

/*
 * Special macro to define mutexes, that doesn't do anything
 * if we are not using threads.
 */

#ifdef TCL_THREADS
#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
171
172
173
174
175
176
177

178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
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
#define Tcl_MutexLock(mutexPtr)
#define Tcl_MutexUnlock(mutexPtr)
#define Tcl_MutexFinalize(mutexPtr)
#define Tcl_ConditionNotify(condPtr)
#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */


#ifndef BUFSIZ
#   include <stdio.h>
#endif


/*
 * Definitions that allow Tcl functions with variable numbers of
 * arguments to be used with either varargs.h or stdarg.h.  TCL_VARARGS
 * is used in procedure prototypes.  TCL_VARARGS_DEF is used to declare
 * the arguments in a function definiton: it takes the type and name of
 * the first argument and supplies the appropriate argument declaration
 * string for use in the function definition.  TCL_VARARGS_START
 * initializes the va_list data structure and returns the first argument.
 */
#if defined(__STDC__) || defined(HAS_STDARG)
#   include <stdarg.h>
#   define TCL_VARARGS(type, name) (type name, ...)
#   define TCL_VARARGS_DEF(type, name) (type name, ...)
#   define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
#   include <varargs.h>
#   ifdef __cplusplus
#      define TCL_VARARGS(type, name) (type name, ...)
#      define TCL_VARARGS_DEF(type, name) (type va_alist, ...)
#   else
#      define TCL_VARARGS(type, name) ()
#      define TCL_VARARGS_DEF(type, name) (va_alist)
#   endif
#   define TCL_VARARGS_START(type, name, list) \
	(va_start(list), va_arg(list, type))
#endif


/*
 * Macros used to declare a function to be exported by a DLL.
 * Used by Windows, maps to no-op declarations on non-Windows systems.
 * The default build on windows is for a DLL, which causes the DLLIMPORT
 * and DLLEXPORT macros to be nonempty. To build a static library, the
 * macro STATIC_BUILD should be defined.







>















|






<
<
<
<


<



<







155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184




185
186

187
188
189

190
191
192
193
194
195
196
#define Tcl_MutexLock(mutexPtr)
#define Tcl_MutexUnlock(mutexPtr)
#define Tcl_MutexFinalize(mutexPtr)
#define Tcl_ConditionNotify(condPtr)
#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */


#ifndef BUFSIZ
#   include <stdio.h>
#endif


/*
 * Definitions that allow Tcl functions with variable numbers of
 * arguments to be used with either varargs.h or stdarg.h.  TCL_VARARGS
 * is used in procedure prototypes.  TCL_VARARGS_DEF is used to declare
 * the arguments in a function definiton: it takes the type and name of
 * the first argument and supplies the appropriate argument declaration
 * string for use in the function definition.  TCL_VARARGS_START
 * initializes the va_list data structure and returns the first argument.
 */
#if !defined(NO_STDARG)
#   include <stdarg.h>
#   define TCL_VARARGS(type, name) (type name, ...)
#   define TCL_VARARGS_DEF(type, name) (type name, ...)
#   define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
#   include <varargs.h>




#      define TCL_VARARGS(type, name) ()
#      define TCL_VARARGS_DEF(type, name) (va_alist)

#   define TCL_VARARGS_START(type, name, list) \
	(va_start(list), va_arg(list, type))
#endif


/*
 * Macros used to declare a function to be exported by a DLL.
 * Used by Windows, maps to no-op declarations on non-Windows systems.
 * The default build on windows is for a DLL, which causes the DLLIMPORT
 * and DLLEXPORT macros to be nonempty. To build a static library, the
 * macro STATIC_BUILD should be defined.
263
264
265
266
267
268
269
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
 */
#undef _ANSI_ARGS_
#undef CONST
#ifndef INLINE
#   define INLINE
#endif

#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE)
#   define _USING_PROTOTYPES_ 1
#   define _ANSI_ARGS_(x)	x
#   define CONST const
#else




#   define _ANSI_ARGS_(x)	()

#   define CONST
#endif

#ifdef USE_NON_CONST



#   define CONST84

#else




#   define CONST84 CONST


#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
















/*
 * 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 __WIN32__
#   ifndef VOID
#      ifdef __STDC__
#         define VOID void
#      else
#         define VOID char
#      endif
#   endif
#else /* __WIN32__ */
/*
 * The following code is copied from winnt.h
 */
#   ifndef VOID
#      define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#   endif
#endif /* __WIN32__ */


/*
 * Miscellaneous declarations.
 */
#ifndef NULL
#   define NULL 0
#endif

#ifndef _CLIENTDATA
#   if defined(__STDC__) || defined(__cplusplus) || defined(__BORLANDC__)
typedef void *ClientData;
#   else
typedef int *ClientData;
#   endif /* __STDC__ */
#   define _CLIENTDATA
#endif


/*
 * Define Tcl_WideInt to be a type that is (at least) 64-bits wide,
 * and define Tcl_WideUInt to be the unsigned variant of that type
 * (assuming that where we have one, we can have the other.)
 *
 * At the moment, this only works on Unix systems anyway...







<
<
|


>
>
>
>
|
>
|



>
>
>

>

>
>
>
>
|
>
>

















>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
|
<

|

<
|
<
<
<
<
<
<
<
<
<
<
<
<









|
|

|
|


<







242
243
244
245
246
247
248


249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312

313
314
315

316












317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332

333
334
335
336
337
338
339
 */
#undef _ANSI_ARGS_
#undef CONST
#ifndef INLINE
#   define INLINE
#endif



#ifndef NO_CONST
#   define CONST const
#else
#   define CONST
#endif

#ifndef NO_PROTOTYPES
#   define _ANSI_ARGS_(x)	x
#else
#   define _ANSI_ARGS_(x)	()
#endif

#ifdef USE_NON_CONST
#   ifdef USE_COMPAT_CONST
#      error define at most one of USE_NON_CONST and USE_COMPAT_CONST
#   endif
#   define CONST84
#   define CONST84_RETURN
#else
#   ifdef USE_COMPAT_CONST
#      define CONST84 
#      define CONST84_RETURN CONST
#   else
#      define CONST84 CONST
#      define CONST84_RETURN CONST
#   endif
#endif


/*
 * Make sure EXTERN isn't defined elsewhere
 */
#ifdef EXTERN
#   undef EXTERN
#endif /* EXTERN */

#ifdef __cplusplus
#   define EXTERN extern "C" TCL_STORAGE_CLASS
#else
#   define EXTERN extern TCL_STORAGE_CLASS
#endif


/*
 * The following code is copied from winnt.h.
 * If we don't replicate it here, then <windows.h> can't be included 
 * after tcl.h, since tcl.h also defines VOID.
 */
#ifdef __WIN32__
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
#endif /* __WIN32__ */

/*
 * Macro to use instead of "void" for arguments that must have
 * type "void *" in ANSI C;  maps them to type "char *" in
 * non-ANSI systems.
 */

#ifndef NO_VOID

#         define VOID void
#else
#         define VOID char

#endif













/*
 * Miscellaneous declarations.
 */
#ifndef NULL
#   define NULL 0
#endif

#ifndef _CLIENTDATA
#   ifndef NO_VOID
	typedef void *ClientData;
#   else
	typedef int *ClientData;
#   endif
#   define _CLIENTDATA
#endif


/*
 * Define Tcl_WideInt to be a type that is (at least) 64-bits wide,
 * and define Tcl_WideUInt to be the unsigned variant of that type
 * (assuming that where we have one, we can have the other.)
 *
 * At the moment, this only works on Unix systems anyway...
362
363
364
365
366
367
368

369
370
371
372
373
374
375
 * implementation (in tclObj.c) depends on the functions strtoull()
 * and, where sprintf(...,"%lld",...) does not work, lltostr().
 * Although strtoull() is fairly straight-forward, lltostr() is a most
 * unusual function on Solaris8 (taking its operating buffer
 * backwards) so any changes you make will need to be done
 * cautiously...
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   ifdef __WIN32__
#      define TCL_WIDE_INT_TYPE __int64
#      ifdef __BORLANDC__
typedef struct stati64 Tcl_StatBuf;
#         define TCL_LL_MODIFIER	"L"
#         define TCL_LL_MODIFIER_SIZE	1







>







353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
 * implementation (in tclObj.c) depends on the functions strtoull()
 * and, where sprintf(...,"%lld",...) does not work, lltostr().
 * Although strtoull() is fairly straight-forward, lltostr() is a most
 * unusual function on Solaris8 (taking its operating buffer
 * backwards) so any changes you make will need to be done
 * cautiously...
 */

#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
#   ifdef __WIN32__
#      define TCL_WIDE_INT_TYPE __int64
#      ifdef __BORLANDC__
typedef struct stati64 Tcl_StatBuf;
#         define TCL_LL_MODIFIER	"L"
#         define TCL_LL_MODIFIER_SIZE	1
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
#   define TCL_WIDE_INT_TYPE	long
#endif /* TCL_WIDE_INT_IS_LONG */

typedef TCL_WIDE_INT_TYPE		Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE	Tcl_WideUInt;

#ifdef TCL_WIDE_INT_IS_LONG
#   ifndef MAC_TCL
#   include <sys/types.h>
#   endif
typedef struct stat	Tcl_StatBuf;
#   define Tcl_WideAsLong(val)		((long)(val))
#   define Tcl_LongAsWide(val)		((long)(val))
#   define Tcl_WideAsDouble(val)	((double)((long)(val)))
#   define Tcl_DoubleAsWide(val)	((long)((double)(val)))
#else /* TCL_WIDE_INT_IS_LONG */
#   ifndef __WIN32__
#      ifndef MAC_TCL
#      include <sys/types.h>
#      endif
#      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







<
<
<







<
<
<







392
393
394
395
396
397
398



399
400
401
402
403
404
405



406
407
408
409
410
411
412
#   define TCL_WIDE_INT_TYPE	long
#endif /* TCL_WIDE_INT_IS_LONG */

typedef TCL_WIDE_INT_TYPE		Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE	Tcl_WideUInt;

#ifdef TCL_WIDE_INT_IS_LONG



typedef struct stat	Tcl_StatBuf;
#   define Tcl_WideAsLong(val)		((long)(val))
#   define Tcl_LongAsWide(val)		((long)(val))
#   define Tcl_WideAsDouble(val)	((double)((long)(val)))
#   define Tcl_DoubleAsWide(val)	((long)((double)(val)))
#else /* TCL_WIDE_INT_IS_LONG */
#   ifndef __WIN32__



#      ifdef HAVE_STRUCT_STAT64
typedef struct stat64	Tcl_StatBuf;
#      else
typedef struct stat	Tcl_StatBuf;
#      endif /* HAVE_STRUCT_STAT64 */
#      define TCL_LL_MODIFIER		"ll"
#      define TCL_LL_MODIFIER_SIZE	2
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
typedef struct Tcl_RegExp_ *Tcl_RegExp;
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;


/*
 * Definition of the interface to procedures implementing threads.
 * A procedure following this definition is given to each call of
 * 'Tcl_CreateThread' and will be called as the main fuction of
 * the new thread created by that call.
 */







|







475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
typedef struct Tcl_RegExp_ *Tcl_RegExp;
typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;

/*
 * Definition of the interface to procedures implementing threads.
 * A procedure following this definition is given to each call of
 * 'Tcl_CreateThread' and will be called as the main fuction of
 * the new thread created by that call.
 */
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
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, char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
	ClientData cmdClientData, int argc, 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,







|


|







652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int code));
typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int argc, CONST84 char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
	ClientData cmdClientData, int argc, CONST84 char *argv[]));
typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int level, CONST char *command,
	Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, 
        struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
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, 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_(());
typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_(());
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







|







|
|







696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
        Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
	struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags));
typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
	int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
	Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));


/*
 * The following structure represents a type of object, which is a
 * particular internal representation for an object plus a set of
1018
1019
1020
1021
1022
1023
1024

1025
1026
1027
1028
1029
1030
1031
 * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj.
 * WARNING: these bit choices must not conflict with the bit choices
 * for evalFlag bits in tclInt.h!!
 */
#define TCL_NO_EVAL		0x10000
#define TCL_EVAL_GLOBAL		0x20000
#define TCL_EVAL_DIRECT		0x40000


/*
 * Special freeProc values that may be passed to Tcl_SetResult (see
 * the man page for details):
 */
#define TCL_VOLATILE	((Tcl_FreeProc *) 1)
#define TCL_STATIC	((Tcl_FreeProc *) 0)







>







1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
 * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj.
 * WARNING: these bit choices must not conflict with the bit choices
 * for evalFlag bits in tclInt.h!!
 */
#define TCL_NO_EVAL		0x10000
#define TCL_EVAL_GLOBAL		0x20000
#define TCL_EVAL_DIRECT		0x40000
#define TCL_EVAL_INVOKE	        0x80000

/*
 * Special freeProc values that may be passed to Tcl_SetResult (see
 * the man page for details):
 */
#define TCL_VOLATILE	((Tcl_FreeProc *) 1)
#define TCL_STATIC	((Tcl_FreeProc *) 0)
1058
1059
1060
1061
1062
1063
1064








1065
1066
1067
1068
1069
1070
1071
 */

#define TCL_TRACE_RENAME 0x2000
#define TCL_TRACE_DELETE 0x4000

#define TCL_ALLOW_INLINE_COMPILATION 0x20000









/*
 * The TCL_PARSE_PART1 flag is deprecated and has no effect. 
 * The part1 is now always parsed whenever the part2 is NULL.
 * (This is to avoid a common error when converting code to
 *  use the new object based APIs and forgetting to give the
 *  flag)
 */







>
>
>
>
>
>
>
>







1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
 */

#define TCL_TRACE_RENAME 0x2000
#define TCL_TRACE_DELETE 0x4000

#define TCL_ALLOW_INLINE_COMPILATION 0x20000

/*
 * Flag values passed to Tcl_CreateObjTrace, and used internally
 * by command execution traces.  Slots 4,8,16 and 32 are
 * used internally by execution traces (see tclCmdMZ.c)
 */
#define TCL_TRACE_ENTER_EXEC		1
#define TCL_TRACE_LEAVE_EXEC		2

/*
 * The TCL_PARSE_PART1 flag is deprecated and has no effect. 
 * The part1 is now always parsed whenever the part2 is NULL.
 * (This is to avoid a common error when converting code to
 *  use the new object based APIs and forgetting to give the
 *  flag)
 */
1606
1607
1608
1609
1610
1611
1612
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
/*
 * 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, 
	CONST84 char *modeString, int permissions));
typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, 
	Tcl_Obj *result, Tcl_Obj *pathPtr, CONST84 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_((ClientData clientData));
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 CONST84 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));
typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, 
			    Tcl_Obj *pathPtr,
			    CONST char * sym1, CONST char * sym2, 
			    Tcl_PackageInitProc ** proc1Ptr, 
			    Tcl_PackageInitProc ** proc2Ptr, 
			    ClientData * clientDataPtr,
			    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));







|

|















|










|





|


<
<
<
|







1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645



1646
1647
1648
1649
1650
1651
1652
1653
/*
 * Typedefs for the various filesystem operations:
 */
typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) 
	_ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, 
	int mode, int permissions));
typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, 
	Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, 
	Tcl_GlobTypeData * types));
typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
					   Tcl_StatBuf *buf));
typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
	   Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
			    Tcl_Obj *destPathPtr));
typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
			    int recursive, Tcl_Obj **errorPtr));
typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
			    Tcl_Obj *destPathPtr));
typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
/* We have to declare the utime structure here. */
struct utimbuf;
typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
					   struct utimbuf *tval));
typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, 
			 Tcl_Obj *pathPtr, int nextCheckpoint));
typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
			    int index, Tcl_Obj *pathPtr,
			    Tcl_Obj **objPtrRef));
typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    Tcl_Obj** objPtrRef));
typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
			    int index, Tcl_Obj *pathPtr,
			    Tcl_Obj *objPtr));
typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
					       Tcl_Obj *toPtr, int linkType));
typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, 
			    Tcl_Obj *pathPtr,



			    Tcl_LoadHandle *handlePtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr));
typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    ClientData *clientDataPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) 
			    _ANSI_ARGS_((Tcl_Obj *pathPtr));
typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) 
			    _ANSI_ARGS_((Tcl_Obj *pathPtr));
1863
1864
1865
1866
1867
1868
1869











1870
1871
1872
1873
1874
1875
1876
			     * carry out the correct action (i.e. call
			     * the correct system 'chdir' api).  If not
			     * implemented, then 'cd' and 'pwd' will
			     * fail inside the filesystem.
			     */
} Tcl_Filesystem;













/*
 * The following structure represents the Notifier functions that
 * you can override with the Tcl_SetNotifier call.
 */
typedef struct Tcl_NotifierProcs {
    Tcl_SetTimerProc *setTimerProc;







>
>
>
>
>
>
>
>
>
>
>







1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
			     * carry out the correct action (i.e. call
			     * the correct system 'chdir' api).  If not
			     * implemented, then 'cd' and 'pwd' will
			     * fail inside the filesystem.
			     */
} Tcl_Filesystem;

/*
 * The following definitions are used as values for the 'linkAction' flag
 * to Tcl_FSLink, or the linkProc of any filesystem.  Any combination
 * of flags can be given.  For link creation, the linkProc should create
 * a link which matches any of the types given.
 * 
 * TCL_CREATE_SYMBOLIC_LINK:  Create a symbolic or soft link.
 * TCL_CREATE_HARD_LINK:      Create a hard link.
 */
#define TCL_CREATE_SYMBOLIC_LINK   0x01
#define TCL_CREATE_HARD_LINK       0x02

/*
 * The following structure represents the Notifier functions that
 * you can override with the Tcl_SetNotifier call.
 */
typedef struct Tcl_NotifierProcs {
    Tcl_SetTimerProc *setTimerProc;
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
 * 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. */
    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;







|







1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
 * For each word of a command, and for each piece of a word such as a
 * variable reference, one of the following structures is created to
 * describe the token.
 */
typedef struct Tcl_Token {
    int type;			/* Type of token, such as TCL_TOKEN_WORD;
				 * see below for valid types. */
    CONST char *start;		/* First character in token. */
    int size;			/* Number of bytes in token. */
    int numComponents;		/* If this token is composed of other
				 * tokens, this field tells how many of
				 * them there are (including components of
				 * components, etc.).  The component tokens
				 * immediately follow this one. */
} Tcl_Token;
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
/*
 * 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 {
    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. */
    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







|






|







2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
/*
 * A structure of the following type is filled in by Tcl_ParseCommand.
 * It describes a single command parsed from an input string.
 */
#define NUM_STATIC_TOKENS 20

typedef struct Tcl_Parse {
    CONST char *commentStart;	/* Pointer to # that begins the first of
				 * one or more comments preceding the
				 * command. */
    int commentSize;		/* Number of bytes in comments (up through
				 * newline character that terminates the
				 * last comment).  If there were no
				 * comments, this field is 0. */
    CONST char *commandStart;	/* First character in first word of command. */
    int commandSize;		/* Number of bytes in command, including
				 * first character of first word, up
				 * through the terminating newline,
				 * close bracket, or semicolon. */
    int numWords;		/* Total number of words in command.  May
				 * be 0. */
    Tcl_Token *tokenPtr;	/* Pointer to first token representing
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120

    /*
     * The fields below are intended only for the private use of the
     * parser.	They should not be used by procedures that invoke
     * Tcl_ParseCommand.
     */

    char *string;		/* The original command string passed to
				 * Tcl_ParseCommand. */
    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. */
    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.







|

|



|







2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123

    /*
     * The fields below are intended only for the private use of the
     * parser.	They should not be used by procedures that invoke
     * Tcl_ParseCommand.
     */

    CONST char *string;		/* The original command string passed to
				 * Tcl_ParseCommand. */
    CONST char *end;		/* Points to the character just after the
				 * last one in the command string. */
    Tcl_Interp *interp;		/* Interpreter to use for error reporting,
				 * or NULL. */
    CONST char *term;		/* Points to character in string that
				 * terminated most recent token.  Filled in
				 * by ParseTokens.  If an error occurs,
				 * points to beginning of region where the
				 * error occurred (e.g. the open brace if
				 * the close brace is missing). */
    int incomplete;		/* This field is set to 1 by Tcl_ParseCommand
				 * if the command appears to be incomplete.
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285


2286
2287
2288
2289
2290
2291
2292
2293
2294
 * class is neither DLLEXPORT nor DLLIMPORT
 */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS

EXTERN int		Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));

#endif /* RESOURCE_INCLUDED */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT



/*
 * end block for C++
 */
#ifdef __cplusplus
}
#endif

#endif /* _TCL */







|



>
>









2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
 * class is neither DLLEXPORT nor DLLIMPORT
 */
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS

EXTERN int		Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));

#endif /* RC_INVOKED */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* RESOURCE_INCLUDED */

/*
 * end block for C++
 */
#ifdef __cplusplus
}
#endif

#endif /* _TCL */
Changes to generic/tclBasic.c.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.35.8.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
#   include "tclPort.h"
#endif







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBasic.c,v 1.35.8.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_GENERIC_ONLY
#   include "tclPort.h"
#endif
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
    iPtr->interpInfo		= NULL;
    Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);

    iPtr->numLevels = 0;
    iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
    iPtr->framePtr = NULL;
    iPtr->varFramePtr = NULL;
    iPtr->activeTracePtr = NULL;
    iPtr->returnCode = TCL_OK;
    iPtr->errorInfo = NULL;
    iPtr->errorCode = NULL;

    iPtr->appendResult = NULL;
    iPtr->appendAvl = 0;
    iPtr->appendUsed = 0;







|







330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
    iPtr->interpInfo		= NULL;
    Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);

    iPtr->numLevels = 0;
    iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
    iPtr->framePtr = NULL;
    iPtr->varFramePtr = NULL;
    iPtr->activeVarTracePtr = NULL;
    iPtr->returnCode = TCL_OK;
    iPtr->errorInfo = NULL;
    iPtr->errorCode = NULL;

    iPtr->appendResult = NULL;
    iPtr->appendAvl = 0;
    iPtr->appendUsed = 0;
353
354
355
356
357
358
359

360
361
362
363
364
365
366
    iPtr->resolverPtr = NULL;
    iPtr->evalFlags = 0;
    iPtr->scriptFile = NULL;
    iPtr->flags = 0;
    iPtr->tracePtr = NULL;
    iPtr->tracesForbiddingInline = 0;
    iPtr->activeCmdTracePtr = NULL;

    iPtr->assocData = (Tcl_HashTable *) NULL;
    iPtr->execEnvPtr = NULL;	      /* set after namespaces initialized */
    iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
    Tcl_IncrRefCount(iPtr->emptyObjPtr);
    iPtr->resultSpace[0] = 0;

    iPtr->globalNsPtr = NULL;	/* force creation of global ns below */







>







353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
    iPtr->resolverPtr = NULL;
    iPtr->evalFlags = 0;
    iPtr->scriptFile = NULL;
    iPtr->flags = 0;
    iPtr->tracePtr = NULL;
    iPtr->tracesForbiddingInline = 0;
    iPtr->activeCmdTracePtr = NULL;
    iPtr->activeInterpTracePtr = NULL;
    iPtr->assocData = (Tcl_HashTable *) NULL;
    iPtr->execEnvPtr = NULL;	      /* set after namespaces initialized */
    iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
    Tcl_IncrRefCount(iPtr->emptyObjPtr);
    iPtr->resultSpace[0] = 0;

    iPtr->globalNsPtr = NULL;	/* force creation of global ns below */
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
    }

    /*
     * Register the builtin math functions.
     */

    i = 0;
    for (builtinFuncPtr = builtinFuncTable;  builtinFuncPtr->name != NULL;
	    builtinFuncPtr++) {
	Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
		builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
		(Tcl_MathProc *) NULL, (ClientData) 0);
	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
		builtinFuncPtr->name);
	if (hPtr == NULL) {







|







478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
    }

    /*
     * Register the builtin math functions.
     */

    i = 0;
    for (builtinFuncPtr = tclBuiltinFuncTable;  builtinFuncPtr->name != NULL;
	    builtinFuncPtr++) {
	Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
		builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
		(Tcl_MathProc *) NULL, (ClientData) 0);
	hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
		builtinFuncPtr->name);
	if (hPtr == NULL) {
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
    /*
     * This procedure generates an argv array for the string arguments. It
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */

#define NUM_ARGS 20
    char *(argStorage[NUM_ARGS]);
    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 = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
    }

    for (i = 0;  i < objc;  i++) {
	argv[i] = Tcl_GetString(objv[i]);
    }
    argv[objc] = 0;








|
|








|







1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
    /*
     * This procedure generates an argv array for the string arguments. It
     * starts out with stack-allocated space but uses dynamically-allocated
     * storage if needed.
     */

#define NUM_ARGS 20
    CONST char *(argStorage[NUM_ARGS]);
    CONST char **argv = argStorage;

    /*
     * Create the string argument array "argv". Make sure argv is large
     * enough to hold the objc arguments plus 1 extra for the zero
     * end-of-argv word.
     */

    if ((objc + 1) > NUM_ARGS) {
	argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
    }

    for (i = 0;  i < objc;  i++) {
	argv[i] = Tcl_GetString(objv[i]);
    }
    argv[objc] = 0;

1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
 */

int
TclInvokeObjectCommand(clientData, interp, argc, argv)
    ClientData clientData;	/* Points to command's Command structure. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int argc;			/* Number of arguments. */
    register char **argv;	/* Argument strings. */
{
    Command *cmdPtr = (Command *) clientData;
    register Tcl_Obj *objPtr;
    register int i;
    int length, result;

    /*







|







1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
 */

int
TclInvokeObjectCommand(clientData, interp, argc, argv)
    ClientData clientData;	/* Points to command's Command structure. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int argc;			/* Number of arguments. */
    register CONST char **argv;	/* Argument strings. */
{
    Command *cmdPtr = (Command *) clientData;
    register Tcl_Obj *objPtr;
    register int i;
    int length, result;

    /*
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519


2520
2521
2522
2523
2524
2525
2526
     */
    
    TclCleanupCommand(cmdPtr);
    return 0;
}
static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
    Interp *iPtr;		/* Interpreter containing variable. */
    Command *cmdPtr;		/* Variable whose traces are to be
				 * invoked. */
    CONST char *oldName;        /* Command's old name, or NULL if we
                                 * must get the name from cmdPtr */
    CONST char *newName;        /* Command's new name, or NULL if
                                 * the command is not being renamed */
    int flags;			/* Flags passed to trace procedures:
				 * indicates what's happening to variable,
				 * plus other stuff like TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, and
				 * TCL_INTERP_DESTROYED. */
{
    register CommandTrace *tracePtr;
    ActiveCommandTrace active;
    char *result;


    if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
	/* 
	 * While a rename trace is active, we will not process any more
	 * rename traces; while a delete trace is active we will not
	 * process any more delete traces 
	 */
	if (cmdPtr->flags & TCL_TRACE_RENAME) {







|
|






|







>
>







2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
     */
    
    TclCleanupCommand(cmdPtr);
    return 0;
}
static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
    Interp *iPtr;		/* Interpreter containing command. */
    Command *cmdPtr;		/* Command whose traces are to be
				 * invoked. */
    CONST char *oldName;        /* Command's old name, or NULL if we
                                 * must get the name from cmdPtr */
    CONST char *newName;        /* Command's new name, or NULL if
                                 * the command is not being renamed */
    int flags;			/* Flags passed to trace procedures:
				 * indicates what's happening to command,
				 * plus other stuff like TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, and
				 * TCL_INTERP_DESTROYED. */
{
    register CommandTrace *tracePtr;
    ActiveCommandTrace active;
    char *result;
    Tcl_Obj *oldNamePtr = NULL;

    if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
	/* 
	 * While a rename trace is active, we will not process any more
	 * rename traces; while a delete trace is active we will not
	 * process any more delete traces 
	 */
	if (cmdPtr->flags & TCL_TRACE_RENAME) {
2536
2537
2538
2539
2540
2541
2542



2543
2544
2545
2546
2547
2548
2549
2550
2551
2552


2553
2554

2555
2556
2557
2558
2559
2560
2561









2562
2563
2564
2565
2566
2567
2568
    cmdPtr->flags |= CMD_TRACE_ACTIVE;
    cmdPtr->refCount++;
    
    result = NULL;
    active.nextPtr = iPtr->activeCmdTracePtr;
    iPtr->activeCmdTracePtr = &active;




    active.cmdPtr = cmdPtr;
    Tcl_Preserve((ClientData) iPtr);
    for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
	 tracePtr = active.nextTracePtr) {
	active.nextTracePtr = tracePtr->nextPtr;
	if (!(tracePtr->flags & flags)) {
	    continue;
	}
	cmdPtr->flags |= tracePtr->flags;
	if (oldName == NULL) {


	    oldName = Tcl_GetCommandName((Tcl_Interp *) iPtr, 
					 (Tcl_Command) cmdPtr);

	}
	Tcl_Preserve((ClientData) tracePtr);
	(*tracePtr->traceProc)(tracePtr->clientData,
		(Tcl_Interp *) iPtr, oldName, newName, flags);
	cmdPtr->flags &= ~tracePtr->flags;
	Tcl_Release((ClientData) tracePtr);
    }










    /*
     * Restore the variable's flags, remove the record of our active
     * traces, and then return.
     */

    cmdPtr->flags &= ~CMD_TRACE_ACTIVE;







>
>
>










>
>
|
|
>







>
>
>
>
>
>
>
>
>







2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
    cmdPtr->flags |= CMD_TRACE_ACTIVE;
    cmdPtr->refCount++;
    
    result = NULL;
    active.nextPtr = iPtr->activeCmdTracePtr;
    iPtr->activeCmdTracePtr = &active;

    if (flags & TCL_TRACE_DELETE) {
	flags |= TCL_TRACE_DESTROYED;
    }
    active.cmdPtr = cmdPtr;
    Tcl_Preserve((ClientData) iPtr);
    for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
	 tracePtr = active.nextTracePtr) {
	active.nextTracePtr = tracePtr->nextPtr;
	if (!(tracePtr->flags & flags)) {
	    continue;
	}
	cmdPtr->flags |= tracePtr->flags;
	if (oldName == NULL) {
	    TclNewObj(oldNamePtr);
	    Tcl_IncrRefCount(oldNamePtr);
	    Tcl_GetCommandFullName((Tcl_Interp *) iPtr, 
	            (Tcl_Command) cmdPtr, oldNamePtr);
	    oldName = TclGetString(oldNamePtr);
	}
	Tcl_Preserve((ClientData) tracePtr);
	(*tracePtr->traceProc)(tracePtr->clientData,
		(Tcl_Interp *) iPtr, oldName, newName, flags);
	cmdPtr->flags &= ~tracePtr->flags;
	Tcl_Release((ClientData) tracePtr);
    }

    /*
     * If a new object was created to hold the full oldName,
     * free it now.
     */

    if (oldNamePtr != NULL) {
	TclDecrRefCount(oldNamePtr);
    }

    /*
     * Restore the variable's flags, remove the record of our active
     * traces, and then return.
     */

    cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
     * Check depth of nested calls to Tcl_Eval:  if this gets too large,
     * it's probably because of an infinite loop somewhere.
     */

    if (((iPtr->numLevels) >= iPtr->maxNestingDepth) 
	    || (TclpCheckStackSpace() == 0)) {
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		"too many nested calls to Tcl_Eval (infinite loop?)", -1); 
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*







|







2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
     * Check depth of nested calls to Tcl_Eval:  if this gets too large,
     * it's probably because of an infinite loop somewhere.
     */

    if (((iPtr->numLevels) >= iPtr->maxNestingDepth) 
	    || (TclpCheckStackSpace() == 0)) {
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
		"too many nested evaluations (infinite loop?)", -1); 
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
2892
2893
2894
2895
2896
2897
2898
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
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. */
    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 is currently
				 * supported. */

{
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **newObjv;
    int i;
    Trace *tracePtr, *nextPtr;
    char *commandCopy;
    CallFrame *savedVarFramePtr;	/* Saves old copy of iPtr->varFramePtr
					 * in case TCL_EVAL_GLOBAL was set. */
    int code = TCL_OK;



    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.
     */
    




    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);


    if (cmdPtr == NULL) {
	newObjv = (Tcl_Obj **) ckalloc((unsigned)
		((objc + 1) * sizeof (Tcl_Obj *)));
	for (i = objc-1; i >= 0; i--) {
	    newObjv[i+1] = objv[i];
	}
	newObjv[0] = Tcl_NewStringObj("::unknown", -1);
	Tcl_IncrRefCount(newObjv[0]);
	cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
	if (cmdPtr == NULL) {
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "invalid command name \"", Tcl_GetString(objv[0]), "\"",
		    (char *) NULL);
	    code = TCL_ERROR;
	} else if (TclInterpReady(interp) == TCL_ERROR) {
	    code = TCL_ERROR;
	} else {
	    iPtr->numLevels++;
	    code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
	    iPtr->numLevels--;
	}
	Tcl_DecrRefCount(newObjv[0]);
	ckfree((char *) newObjv);
	goto done;
    }
    
    /*
     * Call trace procedures if needed.
     */


    if ( command != NULL && iPtr->tracePtr != NULL ) {
	commandCopy = command;

	/* 
	 * Make a copy of the command if necessary, so that trace
	 * procs will see it.
	 */

	if (length < 0) {
	    length = strlen(command);
	} else if ((size_t)length < strlen(command)) {
	    commandCopy = (char *) ckalloc((unsigned) (length + 1));
	    strncpy(commandCopy, command, (size_t) length);
	    commandCopy[length] = 0;

	}

	/*
	 * Walk through the trace procs
	 */



	for ( tracePtr = iPtr->tracePtr;
	      (code == TCL_OK) && (tracePtr != NULL);
	      tracePtr = nextPtr) {
	    nextPtr = tracePtr->nextPtr;

	    if (iPtr->numLevels > tracePtr->level) {
		continue;
	    }

	    /*
	     * Invoke one trace proc
	     */

	    code = (tracePtr->proc)( tracePtr->clientData,
				     (Tcl_Interp*) iPtr,
				     iPtr->numLevels,
				     commandCopy,
				     (Tcl_Command) cmdPtr,
				     objc,
				     objv );
	}
	
	/*
	 * If we had to copy the command for the trace procs, free the
	 * copy.
	 */

	if (commandCopy != command) {
	    ckfree((char *) commandCopy);
	}

    }
    
    /*
     * Finally, invoke the command's Tcl_ObjCmdProc.
     */
    
    iPtr->cmdCount++;
    if ( code == TCL_OK ) {
	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_GLOBAL) {
	    iPtr->varFramePtr = NULL;
	}
	code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
	iPtr->varFramePtr = savedVarFramePtr;
    }
    if (Tcl_AsyncReady()) {
	code = Tcl_AsyncInvoke(interp, code);
    }



























    /*
     * 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.
     */
    







|











|
|






<
<



>
>






>
>
>
>
>
>
|
|
|
|
|
|
|
>
>
>
>
|
>
>
|
|

|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
>
|
|
|
<
<
|
|
|
<
<
<
<
|
<
>
|
|
<
|
<
>
>
|
|
<
<
|
>
|
|
|
|
<
<
<
|
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<



|

|











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936


2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001


3002
3003
3004




3005

3006
3007
3008

3009

3010
3011
3012
3013


3014
3015
3016
3017
3018
3019



3020







3021
3022











3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
TclEvalObjvInternal(interp, objc, objv, command, length, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * command.  Also used for error
				 * reporting. */
    int objc;			/* Number of words in command. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to objects that are
				 * the words that make up the command. */
    CONST char *command;	/* Points to the beginning of the string
				 * representation of the command; this
				 * is used for traces.  If the string
				 * representation of the command is
				 * unknown, an empty string should be
				 * supplied. If it is NULL, no traces will
				 * be called. */
    int length;			/* Number of bytes in command; if -1, all
				 * characters up to the first null byte are
				 * used. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
				 * currently supported. */

{
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj **newObjv;
    int i;


    CallFrame *savedVarFramePtr;	/* Saves old copy of iPtr->varFramePtr
					 * in case TCL_EVAL_GLOBAL was set. */
    int code = TCL_OK;
    int traceCode = TCL_OK;
    int checkTraces = 1;

    if (objc == 0) {
	return TCL_OK;
    }

    /*
     * If any execution traces rename or delete the current command,
     * we may need (at most) two passes here.
     */
    while (1) {
    
        /*
         * Find the procedure to execute this command. If there isn't one,
         * then see if there is a command "unknown".  If so, create a new
         * word array with "unknown" as the first word and the original
         * command words as arguments.  Then call ourselves recursively
         * to execute it.
         */

	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_INVOKE) {
	    iPtr->varFramePtr = NULL;
	}
        cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
	iPtr->varFramePtr = savedVarFramePtr;

        if (cmdPtr == NULL) {
	    newObjv = (Tcl_Obj **) ckalloc((unsigned)
		((objc + 1) * sizeof (Tcl_Obj *)));
	    for (i = objc-1; i >= 0; i--) {
	        newObjv[i+1] = objv[i];
	    }
	    newObjv[0] = Tcl_NewStringObj("::unknown", -1);
	    Tcl_IncrRefCount(newObjv[0]);
	    cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
	    if (cmdPtr == NULL) {
	        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "invalid command name \"", Tcl_GetString(objv[0]), "\"",
		    (char *) NULL);
	        code = TCL_ERROR;
	    } else if (TclInterpReady(interp) == TCL_ERROR) {
	        code = TCL_ERROR;
	    } else {
	        iPtr->numLevels++;
	        code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
	        iPtr->numLevels--;
	    }
	    Tcl_DecrRefCount(newObjv[0]);
	    ckfree((char *) newObjv);
	    goto done;
        }
    
        /*
         * Call trace procedures if needed.
         */
        if ((checkTraces) && (command != NULL)) {
            int cmdEpoch = cmdPtr->cmdEpoch;
            cmdPtr->refCount++;
            /* If the first set of traces modifies/deletes the command or
             * any existing traces, then the set checkTraces to 0 and


             * go through this while loop one more time.
             */
            if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {




                traceCode = TclCheckInterpTraces(interp, command, length,

                               cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
            }
            if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) 

		    && (traceCode == TCL_OK)) {

                traceCode = TclCheckExecutionTraces(interp, command, length,
                               cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
            }
            cmdPtr->refCount--;


            if (cmdEpoch != cmdPtr->cmdEpoch) {
                /* The command has been modified in some way */
                checkTraces = 0;
                continue;
            }
        }



        break;







    }












    /*
     * Finally, invoke the command's Tcl_ObjCmdProc.
     */
    cmdPtr->refCount++;
    iPtr->cmdCount++;
    if ( code == TCL_OK && traceCode == TCL_OK) {
	savedVarFramePtr = iPtr->varFramePtr;
	if (flags & TCL_EVAL_GLOBAL) {
	    iPtr->varFramePtr = NULL;
	}
	code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
	iPtr->varFramePtr = savedVarFramePtr;
    }
    if (Tcl_AsyncReady()) {
	code = Tcl_AsyncInvoke(interp, code);
    }

    /*
     * Call 'leave' command traces
     */
    if (!(cmdPtr->flags & CMD_IS_DELETED)) {
        if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
            traceCode = TclCheckExecutionTraces (interp, command, length,
                   cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
        }
        if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
            traceCode = TclCheckInterpTraces(interp, command, length,
                   cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
        }
    }
    TclCleanupCommand(cmdPtr);

    /*
     * If one of the trace invocation resulted in error, then 
     * change the result code accordingly. Note, that the
     * interp->result should already be set correctly by the
     * call to TraceExecutionProc.  
     */

    if (traceCode != TCL_OK) {
	code = traceCode;
    }
    
    /*
     * If the interpreter has a non-empty string result, the result
     * object is either empty or stale because some procedure set
     * interp->result directly. If so, move the string result to the
     * result object, then reset the string result.
     */
    
3074
3075
3076
3077
3078
3079
3080
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
				 * 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 is 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 (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++) {







|
|















|
<







3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127

3128
3129
3130
3131
3132
3133
3134
				 * command.  Also used for error
				 * reporting. */
    int objc;			/* Number of words in command. */
    Tcl_Obj *CONST objv[];	/* An array of pointers to objects that are
				 * the words that make up the command. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
				 * are  currently supported. */
{
    Interp *iPtr = (Interp *)interp;
    Trace *tracePtr;
    Tcl_DString cmdBuf;
    char *cmdString = "";	/* A command string is only necessary for
				 * command traces or error logs; it will be
				 * generated to replace this default value if
				 * necessary. */
    int cmdLen = 0;		/* a non-zero value indicates that a command
				 * string was generated. */
    int code = TCL_OK;
    int i;
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);

    for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
	if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {

	    /*
	     * The command may be needed for an execution trace.  Generate a
	     * command string.
	     */
	    
	    Tcl_DStringInit(&cmdBuf);
	    for (i = 0; i < objc; i++) {
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
	if ((code != TCL_OK) && (code != TCL_ERROR) 
	    && !allowExceptions) {
	    ProcessUnexpectedResult(interp, code);
	    code = TCL_ERROR;
	}
    }
	    
    if (code == TCL_ERROR) {

	/* 
	 * 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) {







|







3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
	if ((code != TCL_OK) && (code != TCL_ERROR) 
	    && !allowExceptions) {
	    ProcessUnexpectedResult(interp, code);
	    code = TCL_ERROR;
	}
    }
	    
    if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {

	/* 
	 * If there was an error, a command string will be needed for the 
	 * error log: generate it now if it was not done previously.
	 */

	if (cmdLen == 0) {
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
#ifdef TCL_MEM_DEBUG
#   define  MAX_VAR_CHARS 5
#else
#   define  MAX_VAR_CHARS 30
#endif
    char nameBuffer[MAX_VAR_CHARS+1];
    char *varName, *index;
    char *p = NULL;		/* Initialized to avoid compiler warning. */
    int length, code;

    /*
     * The only tricky thing about this procedure is that it attempts to
     * avoid object creation and string copying whenever possible.  For
     * example, if the value is just a nested command, then use the
     * command's result object directly.







|







3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
#ifdef TCL_MEM_DEBUG
#   define  MAX_VAR_CHARS 5
#else
#   define  MAX_VAR_CHARS 30
#endif
    char nameBuffer[MAX_VAR_CHARS+1];
    char *varName, *index;
    CONST char *p = NULL;	/* Initialized to avoid compiler warning. */
    int length, code;

    /*
     * The only tricky thing about this procedure is that it attempts to
     * avoid object creation and string copying whenever possible.  For
     * example, if the value is just a nested command, then use the
     * command's result object directly.
3484
3485
3486
3487
3488
3489
3490
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
 *----------------------------------------------------------------------
 */

int
Tcl_EvalEx(interp, script, numBytes, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * script.  Also used for error reporting. */
    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;
    char *p, *next;
    Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
    Tcl_Token *tokenPtr;
    int i, code, commandLength, bytesLeft, nested;
    CallFrame *savedVarFramePtr;   /* Saves old copy of iPtr->varFramePtr
				    * in case TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
    
    /* For nested scripts, this variable will be set to point to the first 
     * char after the end of the script - needed only to compare pointers,
     * nothing will be read nor written there. 
     */

    char *onePast = NULL;

    /*
     * The variables below keep track of how much state has been
     * allocated while evaluating the script, so that it can be freed
     * properly if an error occurs.
     */








|









|














|







3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
 *----------------------------------------------------------------------
 */

int
Tcl_EvalEx(interp, script, numBytes, flags)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate the
				 * script.  Also used for error reporting. */
    CONST char *script;		/* First character of script to evaluate. */
    int numBytes;		/* Number of bytes in script.  If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int flags;			/* Collection of OR-ed bits that control
				 * the evaluation of the script.  Only
				 * TCL_EVAL_GLOBAL is currently
				 * supported. */
{
    Interp *iPtr = (Interp *) interp;
    CONST char *p, *next;
    Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
    Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
    Tcl_Token *tokenPtr;
    int i, code, commandLength, bytesLeft, nested;
    CallFrame *savedVarFramePtr;   /* Saves old copy of iPtr->varFramePtr
				    * in case TCL_EVAL_GLOBAL was set. */
    int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
    
    /* For nested scripts, this variable will be set to point to the first 
     * char after the end of the script - needed only to compare pointers,
     * nothing will be read nor written there. 
     */

    CONST char *onePast = NULL;

    /*
     * The variables below keep track of how much state has been
     * allocated while evaluating the script, so that it can be freed
     * properly if an error occurs.
     */

3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
    if (gotParse) {
	next = parse.commandStart + parse.commandSize;
	bytesLeft -= next - p;
	p = next;
	Tcl_FreeParse(&parse);

	if ((nested != 0) && (p > script)) {
	    char *nextCmd = NULL;	/* pointer to start of next command */

	    /*
	     * We get here in the special case where the TCL_BRACKET_TERM
	     * flag was set in the interpreter.
	     *
	     * At this point, we want to find the end of the script
	     * (either end of script or the closing ']').







|







3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
    if (gotParse) {
	next = parse.commandStart + parse.commandSize;
	bytesLeft -= next - p;
	p = next;
	Tcl_FreeParse(&parse);

	if ((nested != 0) && (p > script)) {
	    CONST char *nextCmd = NULL;	/* pointer to start of next command */

	    /*
	     * We get here in the special case where the TCL_BRACKET_TERM
	     * flag was set in the interpreter.
	     *
	     * At this point, we want to find the end of the script
	     * (either end of script or the closing ']').
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
 *----------------------------------------------------------------------
 */

int
Tcl_Eval(interp, string)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by previous call to Tcl_CreateInterp). */
    char *string;		/* Pointer to TCL command to execute. */
{
    int code;

    code = Tcl_EvalEx(interp, string, -1, 0);

    /*
     * For backwards compatibility with old C code that predates the
     * object system in Tcl 8.0, we have to mirror the object result
     * back into the string result (some callers may expect it there).
     */








|

<
<
|







3787
3788
3789
3790
3791
3792
3793
3794
3795


3796
3797
3798
3799
3800
3801
3802
3803
 *----------------------------------------------------------------------
 */

int
Tcl_Eval(interp, string)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by previous call to Tcl_CreateInterp). */
    CONST char *string;		/* Pointer to TCL command to execute. */
{


    int code = Tcl_EvalEx(interp, string, -1, 0);

    /*
     * For backwards compatibility with old C code that predates the
     * object system in Tcl 8.0, we have to mirror the object result
     * back into the string result (some callers may expect it there).
     */

4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
 *----------------------------------------------------------------------
 */

int
TclInvoke(interp, argc, argv, flags)
    Tcl_Interp *interp;		/* Where to invoke the command. */
    int argc;			/* Count of args. */
    register char **argv;	/* The arg strings; argv[0] is the name of
                                 * the command to invoke. */
    int flags;			/* Combination of flags controlling the
				 * call: TCL_INVOKE_HIDDEN and
				 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Tcl_Obj *objPtr;
    register int i;







|







4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
 *----------------------------------------------------------------------
 */

int
TclInvoke(interp, argc, argv, flags)
    Tcl_Interp *interp;		/* Where to invoke the command. */
    int argc;			/* Count of args. */
    register CONST char **argv;	/* The arg strings; argv[0] is the name of
                                 * the command to invoke. */
    int flags;			/* Combination of flags controlling the
				 * call: TCL_INVOKE_HIDDEN and
				 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Tcl_Obj *objPtr;
    register int i;
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
 *----------------------------------------------------------------------
 */

int
TclGlobalInvoke(interp, argc, argv, flags)
    Tcl_Interp *interp;		/* Where to invoke the command. */
    int argc;			/* Count of args. */
    register char **argv;	/* The arg strings; argv[0] is the name of
                                 * the command to invoke. */
    int flags;			/* Combination of flags controlling the
				 * call: TCL_INVOKE_HIDDEN and
				 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;







|







4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
 *----------------------------------------------------------------------
 */

int
TclGlobalInvoke(interp, argc, argv, flags)
    Tcl_Interp *interp;		/* Where to invoke the command. */
    int argc;			/* Count of args. */
    register CONST char **argv;	/* The arg strings; argv[0] is the name of
                                 * the command to invoke. */
    int flags;			/* Combination of flags controlling the
				 * call: TCL_INVOKE_HIDDEN and
				 * TCL_INVOKE_NO_UNKNOWN. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
    Tcl_Interp *interp;		/* Interpreter in which to create trace. */
    int level;			/* Only call proc for commands at nesting
				 * level<=argument level (1=>top level). */
    Tcl_CmdTraceProc *proc;	/* Procedure to call before executing each
				 * command. */
    ClientData clientData;	/* Arbitrary value word to pass to proc. */
{
    
    StringTraceData* data;
    data = (StringTraceData*) ckalloc( sizeof( *data ));
    data->clientData = clientData;
    data->proc = proc;
    return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
			       (ClientData) data, StringTraceDeleteProc );
}







<







4863
4864
4865
4866
4867
4868
4869

4870
4871
4872
4873
4874
4875
4876
    Tcl_Interp *interp;		/* Interpreter in which to create trace. */
    int level;			/* Only call proc for commands at nesting
				 * level<=argument level (1=>top level). */
    Tcl_CmdTraceProc *proc;	/* Procedure to call before executing each
				 * command. */
    ClientData clientData;	/* Arbitrary value word to pass to proc. */
{

    StringTraceData* data;
    data = (StringTraceData*) ckalloc( sizeof( *data ));
    data->clientData = clientData;
    data->proc = proc;
    return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
			       (ClientData) data, StringTraceDeleteProc );
}
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
    argv[objc] = 0;

    /*
     * Invoke the command procedure.  Note that we cast away const-ness
     * on two parameters for compatibility with legacy code; the code
     * MUST NOT modify either command or argv.
     */
	
    ( data->proc )( data->clientData, interp, level,
		    (char*) command, cmdPtr->proc, cmdPtr->clientData,
		    objc, (char**) argv );

    ckfree( (char*) argv );

    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * StringTraceDeleteProc --
 *







|


|
<



<







4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932

4933
4934
4935

4936
4937
4938
4939
4940
4941
4942
    argv[objc] = 0;

    /*
     * Invoke the command procedure.  Note that we cast away const-ness
     * on two parameters for compatibility with legacy code; the code
     * MUST NOT modify either command or argv.
     */
          
    ( data->proc )( data->clientData, interp, level,
		    (char*) command, cmdPtr->proc, cmdPtr->clientData,
		    objc, argv );

    ckfree( (char*) argv );

    return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * StringTraceDeleteProc --
 *
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
     * Locate the trace entry in the interpreter's trace list,
     * and remove it from the list.
     */

    while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) {
	tracePtr2 = &((*tracePtr2)->nextPtr);
    }
    if ( tracePtr2 == NULL ) {
	return;
    }
    (*tracePtr2) = (*tracePtr2)->nextPtr;
    
    /*
     * If the trace forbids bytecode compilation, change the interpreter's
     * state.  If bytecode compilation is now permitted, flag the fact and
     * advance the compilation epoch so that procs will be recompiled to
     * take advantage of it.
     */








|



|







4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
     * Locate the trace entry in the interpreter's trace list,
     * and remove it from the list.
     */

    while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) {
	tracePtr2 = &((*tracePtr2)->nextPtr);
    }
    if ( *tracePtr2 == NULL ) {
	return;
    }
    (*tracePtr2) = (*tracePtr2)->nextPtr;

    /*
     * If the trace forbids bytecode compilation, change the interpreter's
     * state.  If bytecode compilation is now permitted, flag the fact and
     * advance the compilation epoch so that procs will be recompiled to
     * take advantage of it.
     */

5075
5076
5077
5078
5079
5080
5081
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
     * from the error message in the interpreter's result.
     */

    if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
	iPtr->flags |= ERR_IN_PROGRESS;

	if (iPtr->result[0] == 0) {
	    (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr,
		    TCL_GLOBAL_ONLY);
	} else {		/* use the string result */
	    Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
		    TCL_GLOBAL_ONLY);
	}

	/*
	 * If the errorCode variable wasn't set by the code that generated
	 * the error, set it to "NONE".
	 */

	if (!(iPtr->flags & ERROR_CODE_SET)) {
	    (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
		    TCL_GLOBAL_ONLY);
	}
    }

    /*
     * Now append "message" to the end of errorInfo.
     */

    if (length != 0) {
	messagePtr = Tcl_NewStringObj(message, length);
	Tcl_IncrRefCount(messagePtr);
	Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr,
		(TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
	Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
    }
}

/*
 *---------------------------------------------------------------------------
 *







|
|

|
|








|
|










|
|







5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
     * from the error message in the interpreter's result.
     */

    if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
	iPtr->flags |= ERR_IN_PROGRESS;

	if (iPtr->result[0] == 0) {
	    Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 
	            iPtr->objResultPtr, TCL_GLOBAL_ONLY);
	} else {		/* use the string result */
	    Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 
	            Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
	}

	/*
	 * If the errorCode variable wasn't set by the code that generated
	 * the error, set it to "NONE".
	 */

	if (!(iPtr->flags & ERROR_CODE_SET)) {
	    Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL, 
	            Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY);
	}
    }

    /*
     * Now append "message" to the end of errorInfo.
     */

    if (length != 0) {
	messagePtr = Tcl_NewStringObj(message, length);
	Tcl_IncrRefCount(messagePtr);
	Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL, 
	        messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
	Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
    }
}

/*
 *---------------------------------------------------------------------------
 *
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
 *
 ---------------------------------------------------------------------------
 */

int
Tcl_GlobalEval(interp, command)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */
    char *command;		/* Command to evaluate. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr;

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = NULL;







|







5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
 *
 ---------------------------------------------------------------------------
 */

int
Tcl_GlobalEval(interp, command)
    Tcl_Interp *interp;		/* Interpreter in which to evaluate command. */
    CONST char *command;	/* Command to evaluate. */
{
    register Interp *iPtr = (Interp *) interp;
    int result;
    CallFrame *savedVarFramePtr;

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = NULL;
Changes to generic/tclCkalloc.c.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.12.14.1 2002/02/05 02:21:58 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

#define FALSE	0
#define TRUE	1







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This code contributed by Karl Lehenbauer and Mark Diekhans
 *
 * RCS: @(#) $Id: tclCkalloc.c,v 1.12.14.2 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

#define FALSE	0
#define TRUE	1
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
static int ckallocInit = 0;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char *argv[]));
static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
static void		ValidateMemory _ANSI_ARGS_((
			    struct mem_header *memHeaderP, CONST char *file,
			    int line, int nukeGuards));

/*
 *----------------------------------------------------------------------
 *







|

|







124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
static int ckallocInit = 0;

/*
 * Prototypes for procedures defined in this file:
 */

static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char *argv[]));
static int		MemoryCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static void		ValidateMemory _ANSI_ARGS_((
			    struct mem_header *memHeaderP, CONST char *file,
			    int line, int nukeGuards));

/*
 *----------------------------------------------------------------------
 *
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
        Tcl_ValidateAllMemory (file, line);

    result = (struct mem_header *) TclpAlloc((unsigned)size + 
                              sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
        fflush(stdout);
        TclDumpMemoryInfo(stderr);
        panic("unable to alloc %d 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.
     */







|







374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
        Tcl_ValidateAllMemory (file, line);

    result = (struct mem_header *) TclpAlloc((unsigned)size + 
                              sizeof(struct mem_header) + HIGH_GUARD_SIZE);
    if (result == NULL) {
        fflush(stdout);
        TclDumpMemoryInfo(stderr);
        panic("unable to alloc %ud bytes, %s line %d", size, file, line);
    }

    /*
     * Fill in guard zones and size.  Also initialize the contents of
     * the block with bogus bytes to detect uses of initialized data.
     * Link into allocated list.
     */
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing)
        fprintf(stderr,"ckalloc %lx %d %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);







|







418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing)
        fprintf(stderr,"ckalloc %lx %ud %s %d\n",
		(long unsigned int) result->body, size, file, line);

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
        (void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing)
        fprintf(stderr,"ckalloc %lx %d %s %d\n",
		(long unsigned int) result->body, size, file, line);

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
        (void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);







|







503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
                total_mallocs);
        fflush(stderr);
        alloc_tracing = TRUE;
        trace_on_at_malloc = 0;
    }

    if (alloc_tracing)
        fprintf(stderr,"ckalloc %lx %ud %s %d\n",
		(long unsigned int) result->body, size, file, line);

    if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
        break_on_malloc = 0;
        (void) fflush(stdout);
        fprintf(stderr,"reached malloc break limit (%d)\n", 
                total_mallocs);
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
 */
	/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
    ClientData  clientData;
    Tcl_Interp *interp;
    int         argc;
    char      **argv;
{
    CONST char *fileName;
    Tcl_DString buffer;
    int result;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",







|







777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
 */
	/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
    ClientData  clientData;
    Tcl_Interp *interp;
    int         argc;
    CONST char  **argv;
{
    CONST char *fileName;
    Tcl_DString buffer;
    int result;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
 */

static int
CheckmemCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Interpreter for evaluation. */
    int argc;				/* Number of arguments. */
    char *argv[];			/* String values of arguments. */
{
    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" fileName\"", (char *) NULL);
	return TCL_ERROR;
    }
    tclMemDumpFileName = dumpFile;







|







929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
 */

static int
CheckmemCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Interpreter for evaluation. */
    int argc;				/* Number of arguments. */
    CONST char *argv[];			/* String values of arguments. */
{
    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" fileName\"", (char *) NULL);
	return TCL_ERROR;
    }
    tclMemDumpFileName = dumpFile;
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
     * by returning NULL, so we have to check that the NULL we get is
     * not in response to alloc(0).
     *
     * The ANSI spec actually says that systems either return NULL *or*
     * a special pointer on failure, but we only check for NULL
     */
    if ((result == NULL) && size) {
	panic("unable to alloc %d bytes", size);
    }
    return result;
}

char *
Tcl_DbCkalloc(size, file, line)
    unsigned int size;
    CONST char  *file;
    int          line;
{
    char *result;

    result = (char *) TclpAlloc(size);

    if ((result == NULL) && size) {
        fflush(stdout);
        panic("unable to alloc %d bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|
















|







1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
     * by returning NULL, so we have to check that the NULL we get is
     * not in response to alloc(0).
     *
     * The ANSI spec actually says that systems either return NULL *or*
     * a special pointer on failure, but we only check for NULL
     */
    if ((result == NULL) && size) {
	panic("unable to alloc %ud bytes", size);
    }
    return result;
}

char *
Tcl_DbCkalloc(size, file, line)
    unsigned int size;
    CONST char  *file;
    int          line;
{
    char *result;

    result = (char *) TclpAlloc(size);

    if ((result == NULL) && size) {
        fflush(stdout);
        panic("unable to alloc %ud bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
    unsigned int size;
{
    char *result;

    result = TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
	panic("unable to realloc %d bytes", size);
    }
    return result;
}

char *
Tcl_DbCkrealloc(ptr, size, file, line)
    char        *ptr;
    unsigned int size;
    CONST char  *file;
    int          line;
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
        fflush(stdout);
        panic("unable to realloc %d bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *







|

















|







1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
    unsigned int size;
{
    char *result;

    result = TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
	panic("unable to realloc %ud bytes", size);
    }
    return result;
}

char *
Tcl_DbCkrealloc(ptr, size, file, line)
    char        *ptr;
    unsigned int size;
    CONST char  *file;
    int          line;
{
    char *result;

    result = (char *) TclpRealloc(ptr, size);

    if ((result == NULL) && size) {
        fflush(stdout);
        panic("unable to realloc %ud bytes, %s line %d", size, file, line);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240

1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
 *---------------------------------------------------------------------------
 */

void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
    Tcl_MutexLock(ckallocMutexPtr);
    if (tclMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(tclMemDumpFileName);
    } else if (onExitMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(onExitMemDumpFileName);
    }

    if (curTagPtr != NULL) {
	TclpFree((char *) curTagPtr);
	curTagPtr = NULL;
    }
    allocHead = NULL;
    Tcl_MutexUnlock(ckallocMutexPtr);
#endif

#if USE_TCLALLOC
    TclFinalizeAllocSubsystem(); 
#endif
}







<





>












1228
1229
1230
1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
 *---------------------------------------------------------------------------
 */

void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG

    if (tclMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(tclMemDumpFileName);
    } else if (onExitMemDumpFileName != NULL) {
	Tcl_DumpActiveMemory(onExitMemDumpFileName);
    }
    Tcl_MutexLock(ckallocMutexPtr);
    if (curTagPtr != NULL) {
	TclpFree((char *) curTagPtr);
	curTagPtr = NULL;
    }
    allocHead = NULL;
    Tcl_MutexUnlock(ckallocMutexPtr);
#endif

#if USE_TCLALLOC
    TclFinalizeAllocSubsystem(); 
#endif
}
Changes to generic/tclClock.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclClock.c --
 *
 *	Contains the time and date related commands.  This code
 *	is derived from the time and date facilities of TclX,
 *	by Mark Diekhans and Karl Lehenbauer.
 *
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.11.14.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"

/*













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclClock.c --
 *
 *	Contains the time and date related commands.  This code
 *	is derived from the time and date facilities of TclX,
 *	by Mark Diekhans and Karl Lehenbauer.
 *
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclClock.c,v 1.11.14.3 2002/08/20 20:25:25 das Exp $
 */

#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"

/*
323
324
325
326
327
328
329


330
331
332
333
334
335
336

337
338
339
340
341
342
343
    for (bufSize = 1, p = format; *p != '\0'; p++) {
	if (*p == '%') {
	    bufSize += 40;
	} else {
	    bufSize++;
	}
    }


    Tcl_DStringInit(&buffer);
    Tcl_DStringSetLength(&buffer, bufSize);

    Tcl_MutexLock(&clockMutex);
    result = TclpStrftime(buffer.string, (unsigned int) bufSize, format,
	    timeDataPtr, useGMT);
    Tcl_MutexUnlock(&clockMutex);


#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
    if (useGMT) {
        if (savedTZEnv != NULL) {
            Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
            ckfree(savedTZEnv);
        } else {







>
>




|
|

>







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
    for (bufSize = 1, p = format; *p != '\0'; p++) {
	if (*p == '%') {
	    bufSize += 40;
	} else {
	    bufSize++;
	}
    }
    Tcl_DStringInit(&uniBuffer);
    Tcl_UtfToExternalDString(NULL, format, -1, &uniBuffer);
    Tcl_DStringInit(&buffer);
    Tcl_DStringSetLength(&buffer, bufSize);

    Tcl_MutexLock(&clockMutex);
    result = TclpStrftime(buffer.string, (unsigned int) bufSize,
	    Tcl_DStringValue(&uniBuffer), timeDataPtr, useGMT);
    Tcl_MutexUnlock(&clockMutex);
    Tcl_DStringFree(&uniBuffer);

#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
    if (useGMT) {
        if (savedTZEnv != NULL) {
            Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
            ckfree(savedTZEnv);
        } else {
Changes to generic/tclCmdAH.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.16.4.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>

/*













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.16.4.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>

/*
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
 * This list of constants should match the fileOption string array below.
 */

    static CONST char *fileOptions[] = {
	"atime",	"attributes",	"channels",	"copy",
	"delete",
	"dirname",	"executable",	"exists",	"extension",
	"isdirectory",	"isfile",	"join",		"lstat",
	"mtime",	"mkdir",	"nativename",	
	"normalize",    "owned",
	"pathtype",	"readable",	"readlink",	"rename",
	"rootname",	"separator",    "size",		"split",	
	"stat",         "system", 
	"tail",		"type",		"volumes",	"writable",
	(char *) NULL
    };
    enum options {
	FILE_ATIME,	FILE_ATTRIBUTES, FILE_CHANNELS,	FILE_COPY,
	FILE_DELETE,
	FILE_DIRNAME,	FILE_EXECUTABLE, FILE_EXISTS,	FILE_EXTENSION,
	FILE_ISDIRECTORY, FILE_ISFILE,	FILE_JOIN,	FILE_LSTAT,
	FILE_MTIME,	FILE_MKDIR,	FILE_NATIVENAME, 
	FILE_NORMALIZE, FILE_OWNED,
	FILE_PATHTYPE,	FILE_READABLE,	FILE_READLINK,	FILE_RENAME,
	FILE_ROOTNAME,	FILE_SEPARATOR, FILE_SIZE,	FILE_SPLIT,	
	FILE_STAT,      FILE_SYSTEM, 
	FILE_TAIL,	FILE_TYPE,	FILE_VOLUMES,	FILE_WRITABLE
    };








|
|











|
|







787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
 * This list of constants should match the fileOption string array below.
 */

    static CONST char *fileOptions[] = {
	"atime",	"attributes",	"channels",	"copy",
	"delete",
	"dirname",	"executable",	"exists",	"extension",
	"isdirectory",	"isfile",	"join",		"link",
	"lstat",        "mtime",	"mkdir",	"nativename",	
	"normalize",    "owned",
	"pathtype",	"readable",	"readlink",	"rename",
	"rootname",	"separator",    "size",		"split",	
	"stat",         "system", 
	"tail",		"type",		"volumes",	"writable",
	(char *) NULL
    };
    enum options {
	FILE_ATIME,	FILE_ATTRIBUTES, FILE_CHANNELS,	FILE_COPY,
	FILE_DELETE,
	FILE_DIRNAME,	FILE_EXECUTABLE, FILE_EXISTS,	FILE_EXTENSION,
	FILE_ISDIRECTORY, FILE_ISFILE,	FILE_JOIN,	FILE_LINK, 
	FILE_LSTAT,     FILE_MTIME,	FILE_MKDIR,	FILE_NATIVENAME, 
	FILE_NORMALIZE, FILE_OWNED,
	FILE_PATHTYPE,	FILE_READABLE,	FILE_READLINK,	FILE_RENAME,
	FILE_ROOTNAME,	FILE_SEPARATOR, FILE_SIZE,	FILE_SPLIT,	
	FILE_STAT,      FILE_SYSTEM, 
	FILE_TAIL,	FILE_TYPE,	FILE_VOLUMES,	FILE_WRITABLE
    };

951
952
953
954
955
956
957


























































































958
959
960
961
962
963
964
		Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
		return TCL_ERROR;
	    }
	    resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
	    Tcl_SetObjResult(interp, resObj);
	    return TCL_OK;
	}


























































































    	case FILE_LSTAT: {
	    char *varName;
	    Tcl_StatBuf buf;

    	    if (objc != 4) {
    	    	Tcl_WrongNumArgs(interp, 2, objv, "name varName");
    	    	return TCL_ERROR;







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
		Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
		return TCL_ERROR;
	    }
	    resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
	    Tcl_SetObjResult(interp, resObj);
	    return TCL_OK;
	}
	case FILE_LINK: {
	    Tcl_Obj *contents;
	    int index;
	    
	    if (objc < 3 || objc > 5) {
		Tcl_WrongNumArgs(interp, 2, objv, 
				 "?-linktype? linkname ?target?");
		return TCL_ERROR;
	    }
	    
	    /* Index of the 'source' argument */
	    if (objc == 5) {
		index = 3;
	    } else {
		index = 2;
	    }
	    
	    if (objc > 3) {
		int linkAction;
		if (objc == 5) {
		    /* We have a '-linktype' argument */
		    static CONST char *linkTypes[] = {
			"-symbolic", "-hard", NULL
		    };
		    if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, 
				     "switch", 0, &linkAction) != TCL_OK) {
			return TCL_ERROR;
		    }
		    if (linkAction == 0) {
		        linkAction = TCL_CREATE_SYMBOLIC_LINK;
		    } else {
			linkAction = TCL_CREATE_HARD_LINK;
		    }
		} else {
		    linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
		}
		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		    return TCL_ERROR;
		}
		/* Create link from source to target */
		contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
		if (contents == NULL) {
		    /* 
		     * We handle two common error cases specially, and
		     * for all other errors, we use the standard posix
		     * error message.
		     */
		    if (errno == EEXIST) {
			Tcl_AppendResult(interp, "could not create new link \"", 
				Tcl_GetString(objv[index]), 
				"\": that path already exists", (char *) NULL);
		    } else if (errno == ENOENT) {
			Tcl_AppendResult(interp, "could not create new link \"", 
				Tcl_GetString(objv[index]), 
				"\" since target \"", 
				Tcl_GetString(objv[index+1]), 
				"\" doesn't exist", 
				(char *) NULL);
		    } else {
			Tcl_AppendResult(interp, "could not create new link \"", 
				Tcl_GetString(objv[index]), "\" pointing to \"", 
				Tcl_GetString(objv[index+1]), "\": ", 
				Tcl_PosixError(interp), (char *) NULL);
		    }
		    return TCL_ERROR;
		}
	    } else {
		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		    return TCL_ERROR;
		}
		/* Read link */
		contents = Tcl_FSLink(objv[index], NULL, 0);
		if (contents == NULL) {
		    Tcl_AppendResult(interp, "could not read link \"", 
			    Tcl_GetString(objv[index]), "\": ", 
			    Tcl_PosixError(interp), (char *) NULL);
		    return TCL_ERROR;
		}
	    }
	    Tcl_SetObjResult(interp, contents);
	    if (objc == 3) {
		/* 
		 * If we are reading a link, we need to free this
		 * result refCount.  If we are creating a link, this
		 * will just be objv[index+1], and so we don't own it.
		 */
		Tcl_DecrRefCount(contents);
	    }
	    return TCL_OK;
	}
    	case FILE_LSTAT: {
	    char *varName;
	    Tcl_StatBuf buf;

    	    if (objc != 4) {
    	    	Tcl_WrongNumArgs(interp, 2, objv, "name varName");
    	    	return TCL_ERROR;
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
		goto only3Args;
	    }
	    
	    if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
		return TCL_ERROR;
	    }

	    contents = Tcl_FSLink(objv[2], NULL);

	    if (contents == NULL) {
	    	Tcl_AppendResult(interp, "could not readlink \"", 
	    		Tcl_GetString(objv[2]), "\": ", 
	    		Tcl_PosixError(interp), (char *) NULL);
	    	return TCL_ERROR;
	    }







|







1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
		goto only3Args;
	    }
	    
	    if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
		return TCL_ERROR;
	    }

	    contents = Tcl_FSLink(objv[2], NULL, 0);

	    if (contents == NULL) {
	    	Tcl_AppendResult(interp, "could not readlink \"", 
	    		Tcl_GetString(objv[2]), "\": ", 
	    		Tcl_PosixError(interp), (char *) NULL);
	    	return TCL_ERROR;
	    }
Changes to generic/tclCmdIL.c.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.35.2.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdIL.c,v 1.35.2.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*
1383
1384
1385
1386
1387
1388
1389
1390

1391
1392
1393
1394
1395
1396
1397
    localVarTablePtr = iPtr->varFramePtr->varTablePtr;

    for (i = 0; i < localVarCt; i++) {
	/*
	 * Skip nameless (temporary) variables and undefined variables
	 */

	if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {

	    varName = varPtr->name;
	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
		Tcl_ListObjAppendElement(interp, listPtr,
		        Tcl_NewStringObj(varName, -1));
	    }
        }
	varPtr++;







|
>







1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
    localVarTablePtr = iPtr->varFramePtr->varTablePtr;

    for (i = 0; i < localVarCt; i++) {
	/*
	 * Skip nameless (temporary) variables and undefined variables
	 */

	if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
	        && (includeLinks || !TclIsVarLink(varPtr))) {
	    varName = varPtr->name;
	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
		Tcl_ListObjAppendElement(interp, listPtr,
		        Tcl_NewStringObj(varName, -1));
	    }
        }
	varPtr++;
Changes to generic/tclCmdMZ.c.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.46.2.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*







|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.46.2.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*
33
34
35
36
37
38
39
40
41
42














43

























44
45
46
47
48
49
50
51
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
				 * 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;

/*
 * The same structure is used for command traces at present
 */















typedef TraceVarInfo TraceCommandInfo;


























/*
 * Forward declarations for procedures defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
	int optionIndex, int objc, Tcl_Obj *CONST objv[]));

Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;


/* 
 * Each subcommand has a number of 'types' to which it can apply.
 * Currently 'command' and 'variable' are the only
 * types supported.  These two 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[] = {
    "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {

    TclTraceCommandObjCmd,
    TclTraceVariableObjCmd,
};








static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, 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));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *	This procedure is invoked to process the "pwd" Tcl command.







|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










>



|
|




|


>




>
>
>
>
>
>
>

|
|



|







33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceVarInfo;

/*
 * Structure used to hold information about command traces:
 */

typedef struct {
    int flags;			/* Operations for which Tcl command is
				 * to be invoked. */
    size_t length;		/* Number of non-NULL chars. in command. */
    Tcl_Trace stepTrace;        /* Used for execution traces, when tracing
                                 * inside the given command */
    int startLevel;             /* Used for bookkeeping with execution traces */
    int curFlags;               /* Trace flags for the current command */
    int curCode;                /* Return code for the current command */
    char command[4];		/* Space for Tcl command to invoke.  Actual
				 * size will be as large as necessary to
				 * hold command.  This field must be the
				 * last in the structure, so that it can
				 * be larger than 4 bytes. */
} TraceCommandInfo;

/* 
 * Used by command execution traces.  Note that we assume in the code
 * that the first two defines are exactly 4 times the
 * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
 * 
 * TCL_TRACE_ENTER_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, before execution.
 * TCL_TRACE_LEAVE_DURING_EXEC  - Trace each command inside the command
 *                                currently being traced, after execution.
 * TCL_TRACE_ANY_EXEC           - OR'd combination of all EXEC flags.
 * TCL_TRACE_EXEC_IN_PROGRESS   - The callback procedure on this trace
 *                                is currently executing.  Therefore we
 *                                don't let further traces execute.
 * TCL_TRACE_EXEC_DIRECT        - This execution trace is triggered directly
 *                                by the command being traced, not because
 *                                of an internal trace.
 * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
 * be used in command execution traces.
 */
#define TCL_TRACE_ENTER_DURING_EXEC	4
#define TCL_TRACE_LEAVE_DURING_EXEC	8
#define TCL_TRACE_ANY_EXEC              15
#define TCL_TRACE_EXEC_IN_PROGRESS      0x10
#define TCL_TRACE_EXEC_DIRECT           0x20

/*
 * Forward declarations for procedures defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
	int optionIndex, int objc, Tcl_Obj *CONST objv[]));

Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;

/* 
 * Each subcommand has a number of 'types' to which it can apply.
 * Currently 'execution', 'command' and 'variable' are the only
 * types supported.  These three arrays MUST be kept in sync!
 * In the future we may provide an API to add to the list of
 * supported trace types.
 */
static CONST char *traceTypeOptions[] = {
    "execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
    TclTraceExecutionObjCmd,
    TclTraceCommandObjCmd,
    TclTraceVariableObjCmd,
};

/*
 * Declarations for local procedures to this file:
 */
static int              CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
                            Trace *tracePtr, Command *cmdPtr,
                            CONST char *command, int numChars,
                            int objc, Tcl_Obj *CONST objv[]));
static char *		TraceVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
                            CONST char *name2, int flags));
static void		TraceCommandProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *oldName,
                            CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *	This procedure is invoked to process the "pwd" Tcl command.
432
433
434
435
436
437
438


439
440
441

442
443
444
445
446
447
448
	}
    }

    /*
     * Set the interpreter's object result to an integer object
     * with value 1 if -all wasn't specified, otherwise it's all-1
     * (the number of times through the while - 1).


     */

    if (!doinline) {

	Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------







>
>



>







480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
	}
    }

    /*
     * Set the interpreter's object result to an integer object
     * with value 1 if -all wasn't specified, otherwise it's all-1
     * (the number of times through the while - 1).
     * Get the resultPtr again as the Tcl_ObjSetVar2 above may have
     * cause the result to change. [Patch #558324] (watson).
     */

    if (!doinline) {
	resultPtr = Tcl_GetObjResult(interp);
	Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
 * Tcl_TraceObjCmd --
 *
 *	This procedure is invoked to process the "trace" Tcl command.
 *	See the user documentation for details on what it does.
 *	
 *	Standard syntax as of Tcl 8.4 is
 *	
 *	 trace {add|remove|list} {command|variable} name ops cmd
 *
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.







|







2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
 * Tcl_TraceObjCmd --
 *
 *	This procedure is invoked to process the "trace" Tcl command.
 *	See the user documentation for details on what it does.
 *	
 *	Standard syntax as of Tcl 8.4 is
 *	
 *	 trace {add|info|remove} {command|variable} name ops cmd
 *
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
2833
2834
2835
2836
2837
2838
2839
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
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int optionIndex, commandLength;
    char *name, *flagOps, *command, *p;
    size_t length;
    /* Main sub commands to 'trace' */
    static CONST char *traceOptions[] = {
	"add", "list", "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_LIST, TRACE_REMOVE, 
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
		"option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE:
	case TRACE_LIST: {
	    /* 
	     * 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) {







|







|

















|







2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int optionIndex, commandLength;
    char *name, *flagOps, *command, *p;
    size_t length;
    /* Main sub commands to 'trace' */
    static CONST char *traceOptions[] = {
	"add", "info", "remove", 
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	"variable", "vdelete", "vinfo", 
#endif
	(char *) NULL
    };
    /* 'OLD' options are pre-Tcl-8.4 style */
    enum traceOptions {
	TRACE_ADD, TRACE_INFO, TRACE_REMOVE, 
#ifndef TCL_REMOVE_OBSOLETE_TRACES
	TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
    };

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
		"option", 0, &optionIndex) != TCL_OK) {
	return TCL_ERROR;
    }
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE:
	case TRACE_INFO: {
	    /* 
	     * All sub commands of trace add/remove must take at least
	     * one more argument.  Beyond that we let the subcommand itself
	     * control the argument structure.
	     */
	    int typeIndex;
	    if (objc < 3) {
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
		tvarPtr = (TraceVarInfo *) clientData;
		if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
			&& (strncmp(command, tvarPtr->command,
				(size_t) length) == 0)) {
		    Tcl_UntraceVar2(interp, name, NULL,
			    flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
			    TraceVarProc, clientData);
		    ckfree((char *) tvarPtr);
		    break;
		}
	    }
	    break;
	}
	case TRACE_OLD_VINFO: {
	    ClientData clientData;







|







3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
		tvarPtr = (TraceVarInfo *) clientData;
		if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
			&& (strncmp(command, tvarPtr->command,
				(size_t) length) == 0)) {
		    Tcl_UntraceVar2(interp, name, NULL,
			    flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
			    TraceVarProc, clientData);
		    Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
		    break;
		}
	    }
	    break;
	}
	case TRACE_OLD_VINFO: {
	    ClientData clientData;
3045
3046
3047
3048
3049
3050
3051

















































































































































































































3052
3053
3054
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
    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *

















































































































































































































 * TclTraceCommandObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|remove|list} 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 list) 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, list 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_LIST, 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;







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|






|








|






|







3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
    return TCL_ERROR;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceExecutionObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|remove|info} execution ...] subcommands.
 *	See the user documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed;
 *	may add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = { "enter", "leave", 
                                 "enterstep", "leavestep", (char *) NULL };
    enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
                      TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
    
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE: {
	    int flags = 0;
	    int i, listLen, result;
	    Tcl_Obj **elemPtrs;
	    if (objc != 6) {
		Tcl_WrongNumArgs(interp, 3, objv, "name opList execution");
		return TCL_ERROR;
	    }
	    /*
	     * Make sure the ops argument is a list object; get its length and
	     * a pointer to its array of element pointers.
	     */

	    result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
		    &elemPtrs);
	    if (result != TCL_OK) {
		return result;
	    }
	    if (listLen == 0) {
		Tcl_SetResult(interp, "bad operation list \"\": must be "
			"one or more of enter, leave, enterstep, or leavestep", TCL_STATIC);
		return TCL_ERROR;
	    }
	    for (i = 0; i < listLen; i++) {
		if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
			"operation", TCL_EXACT, &index) != TCL_OK) {
		    return TCL_ERROR;
		}
		switch ((enum operations) index) {
		    case TRACE_EXEC_ENTER:
			flags |= TCL_TRACE_ENTER_EXEC;
			break;
		    case TRACE_EXEC_LEAVE:
			flags |= TCL_TRACE_LEAVE_EXEC;
			break;
		    case TRACE_EXEC_ENTER_STEP:
			flags |= TCL_TRACE_ENTER_DURING_EXEC;
			break;
		    case TRACE_EXEC_LEAVE_STEP:
			flags |= TCL_TRACE_LEAVE_DURING_EXEC;
			break;
		}
	    }
	    command = Tcl_GetStringFromObj(objv[5], &commandLength);
	    length = (size_t) commandLength;
	    if ((enum traceOptions) optionIndex == TRACE_ADD) {
		TraceCommandInfo *tcmdPtr;
		tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
			(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
				+ length + 1));
		tcmdPtr->flags = flags;
		tcmdPtr->stepTrace = NULL;
		tcmdPtr->startLevel = 0;
		tcmdPtr->length = length;
		flags |= TCL_TRACE_DELETE;
		if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
		    flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
		}
		strcpy(tcmdPtr->command, command);
		name = Tcl_GetString(objv[3]);
		if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
			(ClientData) tcmdPtr) != TCL_OK) {
		    ckfree((char *) tcmdPtr);
		    return TCL_ERROR;
		}
	    } else {
		/*
		 * Search through all of our traces on this command to
		 * see if there's one with the given command.  If so, then
		 * delete the first one that matches.
		 */
		
		TraceCommandInfo *tcmdPtr;
		ClientData clientData;
		clientData = 0;
		name = Tcl_GetString(objv[3]);
		while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
			TraceCommandProc, clientData)) != 0) {
		    tcmdPtr = (TraceCommandInfo *) clientData;
		    /* 
		     * In checking the 'flags' field we must remove any extraneous
		     * flags which may have been temporarily added by various pieces
		     * of the trace mechanism.
		     */
		    if ((tcmdPtr->length == length)
			    && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | 
						   TCL_TRACE_DELETE)) == flags)
			    && (strncmp(command, tcmdPtr->command,
				    (size_t) length) == 0)) {
			flags |= TCL_TRACE_DELETE;
			if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
			    flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
			}
			Tcl_UntraceCommand(interp, name,
				flags, TraceCommandProc, clientData);
			if (tcmdPtr->stepTrace != NULL) {
			    /* 
			     * We need to remove the interpreter-wide trace 
			     * which we created to allow 'step' traces.
			     */
			    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
			    tcmdPtr->stepTrace = NULL;
			}
			/* Postpone deletion */
			if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
			    tcmdPtr->flags = 0;
			} else {
			    Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
			}
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_INFO: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }

	    resultListPtr = Tcl_GetObjResult(interp);
	    clientData = 0;
	    name = Tcl_GetString(objv[3]);
	    while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
		    TraceCommandProc, clientData)) != 0) {

		TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;

		eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

		/*
		 * Build a list with the ops list as the first obj
		 * element and the tcmdPtr->command string as the
		 * second obj element.  Append this list (as an
		 * element) to the end of the result object list.
		 */

		elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
		if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("enter",6));
		}
		if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("leave",5));
		}
		if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("enterstep",9));
		}
		if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
		    Tcl_ListObjAppendElement(NULL, elemObjPtr,
			    Tcl_NewStringObj("leavestep",10));
		}
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);

		elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
		Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
		Tcl_ListObjAppendElement(interp, resultListPtr,
			eachTraceObjPtr);
	    }
	    Tcl_SetObjResult(interp, resultListPtr);
	    break;
	}
    }
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceCommandObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|info|remove} command ...] subcommands.
 *	See the user documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed;
 *	may add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
    enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
    
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
	case TRACE_REMOVE: {
	    int flags = 0;
3122
3123
3124
3125
3126
3127
3128


3129
3130
3131
3132
3133
3134
3135
	    length = (size_t) commandLength;
	    if ((enum traceOptions) optionIndex == TRACE_ADD) {
		TraceCommandInfo *tcmdPtr;
		tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
			(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
				+ length + 1));
		tcmdPtr->flags = flags;


		tcmdPtr->length = length;
		flags |= TCL_TRACE_DELETE;
		strcpy(tcmdPtr->command, command);
		name = Tcl_GetString(objv[3]);
		if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
			(ClientData) tcmdPtr) != TCL_OK) {
		    ckfree((char *) tcmdPtr);







>
>







3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
	    length = (size_t) commandLength;
	    if ((enum traceOptions) optionIndex == TRACE_ADD) {
		TraceCommandInfo *tcmdPtr;
		tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
			(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
				+ length + 1));
		tcmdPtr->flags = flags;
		tcmdPtr->stepTrace = NULL;
		tcmdPtr->startLevel = 0;
		tcmdPtr->length = length;
		flags |= TCL_TRACE_DELETE;
		strcpy(tcmdPtr->command, command);
		name = Tcl_GetString(objv[3]);
		if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
			(ClientData) tcmdPtr) != TCL_OK) {
		    ckfree((char *) tcmdPtr);
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
			ckfree((char *) tcmdPtr);
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_LIST: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }








|







3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
			ckfree((char *) tcmdPtr);
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_INFO: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }

3214
3215
3216
3217
3218
3219
3220
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

/*
 *----------------------------------------------------------------------
 *
 * TclTraceVariableObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|remove|list} 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 list) 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, list 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_LIST, 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: 







|






|








|






|







3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513

/*
 *----------------------------------------------------------------------
 *
 * TclTraceVariableObjCmd --
 *
 *	Helper function for Tcl_TraceObjCmd; implements the
 *	[trace {add|info|remove} variable ...] subcommands.
 *	See the user documentation for details on what these do.
 *
 * Results:
 *	Standard Tcl result.
 *
 * Side effects:
 *	Depends on the operation (add, remove, or info) being performed;
 *	may add or remove variable traces on a variable.
 *
 *----------------------------------------------------------------------
 */

int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
    Tcl_Interp *interp;			/* Current interpreter. */
    int optionIndex;			/* Add, info or remove */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int commandLength, index;
    char *name, *command;
    size_t length;
    enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
    static CONST char *opStrings[] = { "array", "read", "unset", "write",
				     (char *) NULL };
    enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
			  TRACE_VAR_WRITE };
        
    switch ((enum traceOptions) optionIndex) {
	case TRACE_ADD: 
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
		    if ((tvarPtr->length == length)
			    && (tvarPtr->flags == flags)
			    && (strncmp(command, tvarPtr->command,
				    (size_t) length) == 0)) {
			Tcl_UntraceVar2(interp, name, NULL,
				flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
				TraceVarProc, clientData);
			ckfree((char *) tvarPtr);
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_LIST: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }








|






|







3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
		    if ((tvarPtr->length == length)
			    && (tvarPtr->flags == flags)
			    && (strncmp(command, tvarPtr->command,
				    (size_t) length) == 0)) {
			Tcl_UntraceVar2(interp, name, NULL,
				flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
				TraceVarProc, clientData);
			Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
			break;
		    }
		}
	    }
	    break;
	}
	case TRACE_INFO: {
	    ClientData clientData;
	    Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
	    if (objc != 4) {
		Tcl_WrongNumArgs(interp, 3, objv, "name");
		return TCL_ERROR;
	    }

3466
3467
3468
3469
3470
3471
3472



3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
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
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceCommand --
 *
 *	Arrange for rename/deletes to a command to cause a
 *	procedure to be invoked, which can monitor the operations.



 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the command given by cmdName, such that
 *	future changes to the command will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which command is
				 * to be traced. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */

    Tcl_CommandTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
	    NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Set up trace information.
     */

    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE);

    tracePtr->nextPtr = cmdPtr->tracePtr;
    cmdPtr->tracePtr = tracePtr;



    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceCommand --







>
>
>



















|
>




















|
>


>
>
>







3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceCommand --
 *
 *	Arrange for rename/deletes to a command to cause a
 *	procedure to be invoked, which can monitor the operations.
 *	
 *	Also optionally arrange for execution of that command
 *	to cause a procedure to be invoked.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the command given by cmdName, such that
 *	future changes to the command will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which command is
				 * to be traced. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
				 * and any of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
	    NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Set up trace information.
     */

    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
			       | TCL_TRACE_ANY_EXEC);
    tracePtr->nextPtr = cmdPtr->tracePtr;
    cmdPtr->tracePtr = tracePtr;
    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
        cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceCommand --
3535
3536
3537
3538
3539
3540
3541
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
 */

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. */

    Tcl_CommandTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    register CommandTrace *tracePtr;
    CommandTrace *prevPtr;
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveCommandTrace *activePtr;


    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 
		NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE);

    for (tracePtr = cmdPtr->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 CallTraces.
     */

    for (activePtr = iPtr->activeCmdTracePtr;  activePtr != NULL;
	 activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    activePtr->nextTracePtr = tracePtr->nextPtr;
	}
    }
    if (prevPtr == NULL) {
	cmdPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }

    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);














}

/*
 *----------------------------------------------------------------------
 *
 * TraceCommandProc --
 *
 *	This procedure is called to handle command changes that have
 *	been traced using the "trace" command.

 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *







|
>








>
|






|
>





|

>
>
>



|



|













>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>








|
>







3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
 */

void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing command. */
    CONST char *cmdName;	/* Name of command. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
				 * and any of the TRACE_*_EXEC flags */
    Tcl_CommandTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    register CommandTrace *tracePtr;
    CommandTrace *prevPtr;
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveCommandTrace *activePtr;
    int hasExecTraces = 0;
    
    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 
		NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
	return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);

    for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL;  ;
	 prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	if (tracePtr == NULL) {
	    return;
	}
	if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags)
		&& (tracePtr->clientData == clientData)) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
		hasExecTraces = 1;
	    }
	    break;
	}
    }
    
    /*
     * The code below makes it possible to delete traces while traces
     * are active: it makes sure that the deleted trace won't be
     * processed by CallCommandTraces.
     */

    for (activePtr = iPtr->activeCmdTracePtr;  activePtr != NULL;
	 activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    activePtr->nextTracePtr = tracePtr->nextPtr;
	}
    }
    if (prevPtr == NULL) {
	cmdPtr->tracePtr = tracePtr->nextPtr;
    } else {
	prevPtr->nextPtr = tracePtr->nextPtr;
    }
    tracePtr->flags = 0;
    Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC);
    
    if (hasExecTraces) {
	for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
	     prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
	    if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
	        return;
	    }
	}
	/* 
	 * None of the remaining traces on this command are execution
	 * traces.  We therefore remove this flag:
	 */
	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TraceCommandProc --
 *
 *	This procedure is called to handle command changes that have
 *	been traced using the "trace" command, when using the 
 *	'rename' or 'delete' options.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Depends on the command associated with the trace.
 *
3616
3617
3618
3619
3620
3621
3622
3623


3624
3625
3626
3627
3628
3629
3630
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    Tcl_SavedResult state;
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
    int code;
    Tcl_DString cmd;



    if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
	/*
	 * Generate a command to execute by appending list elements
	 * for the old and new command name and the operation.
	 */

	Tcl_DStringInit(&cmd);







|
>
>







3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    Tcl_SavedResult state;
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
    int code;
    Tcl_DString cmd;
    
    Tcl_Preserve((ClientData) tcmdPtr);
    
    if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
	/*
	 * Generate a command to execute by appending list elements
	 * for the old and new command name and the operation.
	 */

	Tcl_DStringInit(&cmd);
3662
3663
3664
3665
3666
3667
3668






3669


3670


3671
3672





































































































































































































































































































































































































































3673
3674
3675
3676
3677
3678
3679
	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)) {






	ckfree((char *) tcmdPtr);


    }


    return;
}






































































































































































































































































































































































































































/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *	This procedure is called to handle variable accesses that have







>
>
>
>
>
>
|
>
>
|
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
	Tcl_DStringFree(&cmd);
    }
    /*
     * We delete when the trace was destroyed or if this is a delete trace,
     * because command deletes are unconditional, so the trace must go away.
     */
    if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
	if (tcmdPtr->stepTrace != NULL) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
	}
	/* Postpone deletion, until exec trace returns */
	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
	    tcmdPtr->flags = 0;
	} else {
	    Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
	}
    }
    Tcl_Release((ClientData) tcmdPtr);
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckExecutionTraces --
 *
 *	Checks on all current command execution traces, and invokes
 *	procedures which have been registered.  This procedure can be
 *	used by other code which performs execution to unify the
 *	tracing system, so that execution traces will function for that
 *	other code.
 *	
 *	For instance extensions like [incr Tcl] which use their
 *	own execution technique can make use of Tcl's tracing.
 *	
 *	This procedure is called by 'TclEvalObjvInternal'
 *
 * Results:
 *      The return value is a standard Tcl completion code such as
 *      TCL_OK or TCL_ERROR, etc.
 *
 * Side effects:
 *	Those side effects made by any trace procedures called.
 *
 *----------------------------------------------------------------------
 */
int 
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    CONST char *command;        /* Pointer to beginning of the current 
				 * command string. */
    int numChars;               /* The number of characters in 'command' 
				 * which are part of the command string. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    int code;                   /* The current result code. */
    int traceFlags;             /* Current tracing situation. */
    int objc;			/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    CommandTrace *tracePtr, *lastTracePtr;
    ActiveCommandTrace active;
    int curLevel;
    int traceCode = TCL_OK;
    TraceCommandInfo* tcmdPtr;
    
    if (command == NULL || cmdPtr->tracePtr == NULL) {
	return(traceCode);
    }
    
    curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
    
    active.nextPtr = iPtr->activeCmdTracePtr;
    iPtr->activeCmdTracePtr = &active;

    active.cmdPtr = cmdPtr;
    lastTracePtr = NULL;
    for ( tracePtr = cmdPtr->tracePtr;
          (traceCode == TCL_OK) && (tracePtr != NULL);
	  tracePtr = active.nextTracePtr) {
        if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
            /* execute the trace command in order of creation for "leave" */
	    active.nextTracePtr = NULL;
            tracePtr = cmdPtr->tracePtr;
            while (tracePtr->nextPtr != lastTracePtr) {
	        active.nextTracePtr = tracePtr;
	        tracePtr = tracePtr->nextPtr;
            }
        } else {
	    active.nextTracePtr = tracePtr->nextPtr;
        }
	tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
	if (tcmdPtr->flags != 0) {
            tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
            tcmdPtr->curCode  = code;
	    traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, 
	          curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
	}
        lastTracePtr = tracePtr;
    }
    iPtr->activeCmdTracePtr = active.nextPtr;
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckInterpTraces --
 *
 *	Checks on all current traces, and invokes procedures which
 *	have been registered.  This procedure can be used by other
 *	code which performs execution to unify the tracing system.
 *	For instance extensions like [incr Tcl] which use their
 *	own execution technique can make use of Tcl's tracing.
 *	
 *	This procedure is called by 'TclEvalObjvInternal'
 *
 * Results:
 *      The return value is a standard Tcl completion code such as
 *      TCL_OK or TCL_ERROR, etc.
 *
 * Side effects:
 *	Those side effects made by any trace procedures called.
 *
 *----------------------------------------------------------------------
 */
int 
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    CONST char *command;        /* Pointer to beginning of the current 
				 * command string. */
    int numChars;               /* The number of characters in 'command' 
				 * which are part of the command string. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    int code;                   /* The current result code. */
    int traceFlags;             /* Current tracing situation. */
    int objc;			/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    Trace *tracePtr, *lastTracePtr;
    ActiveInterpTrace active;
    int curLevel;
    int traceCode = TCL_OK;
    TraceCommandInfo* tcmdPtr;
    
    if (command == NULL || iPtr->tracePtr == NULL ||
           (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
	return(traceCode);
    }
    
    curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
    
    active.nextPtr = iPtr->activeInterpTracePtr;
    iPtr->activeInterpTracePtr = &active;

    lastTracePtr = NULL;
    for ( tracePtr = iPtr->tracePtr;
          (traceCode == TCL_OK) && (tracePtr != NULL);
	  tracePtr = active.nextTracePtr) {
        if (traceFlags & TCL_TRACE_ENTER_EXEC) {
            /* execute the trace command in reverse order of creation
             * for "enterstep" operation. The order is changed for
             * ""enterstep" instead of for "leavestep as was done in 
             * TclCheckExecutionTraces because for step traces,
             * Tcl_CreateObjTrace creates one more linked list of traces
             * which results in one more reversal of trace invocation.
             */
	    active.nextTracePtr = NULL;
            tracePtr = iPtr->tracePtr;
            while (tracePtr->nextPtr != lastTracePtr) {
	        active.nextTracePtr = tracePtr;
	        tracePtr = tracePtr->nextPtr;
            }
        } else {
	    active.nextTracePtr = tracePtr->nextPtr;
        }
	if (tracePtr->level > 0 && curLevel > tracePtr->level) {
	    continue;
	}
	if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
	    tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
	    if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) &&
		((tracePtr->flags & traceFlags) != 0)) {
	            tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
                    tcmdPtr->curFlags = traceFlags;
                    tcmdPtr->curCode  = code;
		    traceCode = (tracePtr->proc)((ClientData)tcmdPtr, 
                                                (Tcl_Interp*)interp,
                                                curLevel, command,
					        (Tcl_Command)cmdPtr,
                                                objc, objv);
	    } else {
		if (traceFlags & TCL_TRACE_ENTER_EXEC) {
		    /* 
		     * Old-style interpreter-wide traces only trigger
		     * before the command is executed.
		     */
		    traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
				       command, numChars, objc, objv);
		}
	    }
	    tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
	}
        lastTracePtr = tracePtr;
    }
    iPtr->activeInterpTracePtr = active.nextPtr;
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * CallTraceProcedure --
 *
 *	Invokes a trace procedure registered with an interpreter. These
 *	procedures trace command execution. Currently this trace procedure
 *	is called with the address of the string-based Tcl_CmdProc for the
 *	command, not the Tcl_ObjCmdProc.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Those side effects made by the trace procedure.
 *
 *----------------------------------------------------------------------
 */

static int
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
    Tcl_Interp *interp;		/* The current interpreter. */
    register Trace *tracePtr;	/* Describes the trace procedure to call. */
    Command *cmdPtr;		/* Points to command's Command struct. */
    CONST char *command;	/* Points to the first character of the
				 * command's source before substitutions. */
    int numChars;		/* The number of characters in the
				 * command's source. */
    register int objc;		/* Number of arguments for the command. */
    Tcl_Obj *CONST objv[];	/* Pointers to Tcl_Obj of each argument. */
{
    Interp *iPtr = (Interp *) interp;
    char *commandCopy;
    int traceCode;

   /*
     * Copy the command characters into a new string.
     */

    commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
    memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
    commandCopy[numChars] = '\0';
    
    /*
     * Call the trace procedure then free allocated storage.
     */
    
    traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
                              iPtr->numLevels, commandCopy,
                              (Tcl_Command) cmdPtr, objc, objv );

    ckfree((char *) commandCopy);
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TraceExecutionProc --
 *
 *	This procedure is invoked whenever code relevant to a
 *	'trace execution' command is executed.  It is called in one
 *	of two ways in Tcl's core:
 *	
 *	(i) by the TclCheckExecutionTraces, when an execution trace has been
 *	triggered.
 *	(ii) by TclCheckInterpTraces, when a prior execution trace has
 *	created a trace of the internals of a procedure, passing in
 *	this procedure as the one to be called.
 *
 * Results:
 *      The return value is a standard Tcl completion code such as
 *      TCL_OK or TCL_ERROR, etc.
 *
 * Side effects:
 *	May invoke an arbitrary Tcl procedure, and may create or
 *	delete an interpreter-wide trace.
 *
 *----------------------------------------------------------------------
 */
int 
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, 
	      int level, CONST char* command, Tcl_Command cmdInfo,
	      int objc, struct Tcl_Obj *CONST objv[]) {
    int call = 0;
    Interp *iPtr = (Interp *) interp;
    TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
    int flags = tcmdPtr->curFlags;
    int code  = tcmdPtr->curCode;
    int traceCode  = TCL_OK;
    
    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
	/* 
	 * Inside any kind of execution trace callback, we do
	 * not allow any further execution trace callbacks to
	 * be called for the same trace.
	 */
	return(traceCode);
    }
    
    if (!(flags & TCL_INTERP_DESTROYED)) {
	/*
	 * Check whether the current call is going to eval arbitrary
	 * Tcl code with a generated trace, or whether we are only
	 * going to setup interpreter-wide traces to implement the
	 * 'step' traces.  This latter situation can happen if
	 * we create a command trace without either before or after
	 * operations, but with either of the step operations.
	 */
	if (flags & TCL_TRACE_EXEC_DIRECT) {
	    call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
	} else {
	    call = 1;
	}
	/*
	 * First, if we have returned back to the level at which we
	 * created an interpreter trace, we remove it
	 */
	if (flags & TCL_TRACE_LEAVE_EXEC) {
	    if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)) {
		Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
		tcmdPtr->stepTrace = NULL;
	    }
	    
	}
	
	/*
	 * Second, create the tcl callback, if required.
	 */
	if (call) {
	    Tcl_SavedResult state;
	    Tcl_DString cmd;
	    Tcl_DString sub;
	    int i;

	    Tcl_DStringInit(&cmd);
	    Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
	    /* Append command with arguments */
	    Tcl_DStringInit(&sub);
	    for (i = 0; i < objc; i++) {
	        char* str;
	        int len;
	        str = Tcl_GetStringFromObj(objv[i],&len);
	        Tcl_DStringAppendElement(&sub, str);
	    }
	    Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
	    Tcl_DStringFree(&sub);

	    if (flags & TCL_TRACE_ENTER_EXEC) {
		/* Append trace operation */
		if (flags & TCL_TRACE_EXEC_DIRECT) {
		    Tcl_DStringAppendElement(&cmd, "enter");
		} else {
		    Tcl_DStringAppendElement(&cmd, "enterstep");
		}
	    } else if (flags & TCL_TRACE_LEAVE_EXEC) {
		Tcl_Obj* resultCode;
		char* resultCodeStr;

		/* Append result code */
		resultCode = Tcl_NewIntObj(code);
		resultCodeStr = Tcl_GetString(resultCode);
		Tcl_DStringAppendElement(&cmd, resultCodeStr);
		Tcl_DecrRefCount(resultCode);
		
		/* Append result string */
		Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
		/* Append trace operation */
		if (flags & TCL_TRACE_EXEC_DIRECT) {
		    Tcl_DStringAppendElement(&cmd, "leave");
		} else {
		    Tcl_DStringAppendElement(&cmd, "leavestep");
		}
	    } else {
		panic("TraceExecutionProc: bad flag combination");
	    }
	    
	    /*
	     * Execute the command.  Save the interp's result used for
	     * the command. We discard any object result the command returns.
	     */

	    Tcl_SaveResult(interp, &state);

	    tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
	    iPtr->flags    |= INTERP_TRACE_IN_PROGRESS;
	    Tcl_Preserve((ClientData)tcmdPtr);
	    /* 
	     * This line can have quite arbitrary side-effects,
	     * including deleting the trace, the command being
	     * traced, or even the interpreter.
	     */
	    traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
	    tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
	    iPtr->flags    &= ~INTERP_TRACE_IN_PROGRESS;
	    if (tcmdPtr->flags == 0) {
		flags |= TCL_TRACE_DESTROYED;
	    }
	    
            if (traceCode == TCL_OK) {
		/* Restore result if trace execution was successful */
		Tcl_RestoreResult(interp, &state);
            }

	    Tcl_DStringFree(&cmd);
	}
	
	/*
	 * Third, create an interpreter trace, if we need one for
	 * subsequent internal execution traces.
	 */
	if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
	    && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) {
		tcmdPtr->startLevel = level;
		tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
		   (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, 
		   TraceExecutionProc, (ClientData)tcmdPtr, NULL);
	}
    }
    if (flags & TCL_TRACE_DESTROYED) {
	if (tcmdPtr->stepTrace != NULL) {
	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
	    tcmdPtr->stepTrace = NULL;
	}
	Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC);
    }
    if (call) {
	Tcl_Release((ClientData)tcmdPtr);
    }
    return(traceCode);
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *	This procedure is called to handle variable accesses that have
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708










3709
3710
3711
3712
3713
3714
3715
 */

	/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Information about the variable trace. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *name1;		/* Name of variable or array. */
    CONST char *name2;		/* Name of element within array;  NULL means
				 * scalar variable is being referenced. */
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    Tcl_SavedResult state;
    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
    char *result;
    int code;
    Tcl_DString cmd;











    result = NULL;
    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
	if (tvarPtr->length != (size_t) 0) {
	    /*
	     * Generate a command to execute by appending list elements
	     * for the two variable names and the operation. 
	     */







|











>
>
>
>
>
>
>
>
>
>







4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
 */

	/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Information about the variable trace. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable or array. */
    CONST char *name2;		/* Name of element within array;  NULL means
				 * scalar variable is being referenced. */
    int flags;			/* OR-ed bits giving operation and other
				 * information. */
{
    Tcl_SavedResult state;
    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
    char *result;
    int code;
    Tcl_DString cmd;

    /* 
     * We might call Tcl_Eval() below, and that might evaluate
     * [trace vdelete] which might try to free tvarPtr.  We want
     * to use tvarPtr until the end of this function, so we use
     * Tcl_Preserve() and Tcl_Release() to be sure it is not 
     * freed while we still need it.
     */

    Tcl_Preserve((ClientData) tvarPtr);

    result = NULL;
    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
	if (tvarPtr->length != (size_t) 0) {
	    /*
	     * Generate a command to execute by appending list elements
	     * for the two variable names and the operation. 
	     */
3774
3775
3776
3777
3778
3779
3780
3781
3782

3783
3784
3785
3786
3787
3788
3789
    if (flags & TCL_TRACE_DESTROYED) {
	if (result != NULL) {
	    register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;

	    Tcl_DecrRefCount(errMsgObj);
	    result = NULL;
	}
	ckfree((char *) tvarPtr);
    }

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileObjCmd --







|

>







4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
    if (flags & TCL_TRACE_DESTROYED) {
	if (result != NULL) {
	    register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;

	    Tcl_DecrRefCount(errMsgObj);
	    result = NULL;
	}
	Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
    }
    Tcl_Release((ClientData) tvarPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileObjCmd --
Changes to generic/tclCompCmds.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclCompCmds.c --
 *
 *	This file contains compilation procedures that compile various
 *	Tcl commands into a sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompCmds.c,v 1.14.4.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for procedures defined later in this file:













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclCompCmds.c --
 *
 *	This file contains compilation procedures that compile various
 *	Tcl commands into a sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompCmds.c,v 1.14.4.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for procedures defined later in this file:
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
     * so push the new value.  This will need to be extended to push a
     * value for each argument.
     */

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,
		    valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);
	} else {
	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}







|
|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
     * so push the new value.  This will need to be extended to push a
     * value for each argument.
     */

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, 
		    valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	} else {
	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    JumpFixup jumpFixup;
    Tcl_Token *cmdTokenPtr, *nameTokenPtr;
    char *name;
    int localIndex, nameChars, range, startOffset, jumpDist;
    int code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;

    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"catch command ?varName?\"", -1);
	return TCL_ERROR;







|


<







237
238
239
240
241
242
243
244
245
246

247
248
249
250
251
252
253
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    JumpFixup jumpFixup;
    Tcl_Token *cmdTokenPtr, *nameTokenPtr;
    CONST char *name;
    int localIndex, nameChars, range, startOffset, jumpDist;
    int code;

    int savedStackDepth = envPtr->currStackDepth;

    if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"catch command ?varName?\"", -1);
	return TCL_ERROR;
317
318
319
320
321
322
323
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
	        cmdTokenPtr->numComponents, envPtr);
	startOffset = (envPtr->codeNext - envPtr->codeStart);
	TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
    envPtr->exceptArrayPtr[range].codeOffset = startOffset;

    if (code != TCL_OK) {
	if (code == TCL_ERROR) {
	    sprintf(buffer, "\n    (\"catch\" body line %d)",
		    interp->errorLine);
            Tcl_AddObjErrorInfo(interp, buffer, -1);
        }
	goto done;
    }
    envPtr->exceptArrayPtr[range].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart) - startOffset;
		    
    /*
     * The "no errors" epilogue code: store the body's result into the
     * variable (if any), push "0" (TCL_OK) as the catch's "no error"
     * result, and jump around the "error case" code.
     */

    if (localIndex != -1) {
	if (localIndex <= 255) {
	    TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
	} else {
	    TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
	}
    }
    TclEmitOpcode(INST_POP, envPtr);
    TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0),
	    envPtr);
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * The "error case" code: store the body's result into the variable (if
     * any), then push the error result code. The initial PC offset here is
     * the catch's error target.
     */







|
<
<
<
<



















|
<







316
317
318
319
320
321
322
323




324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343

344
345
346
347
348
349
350
	        cmdTokenPtr->numComponents, envPtr);
	startOffset = (envPtr->codeNext - envPtr->codeStart);
	TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
    envPtr->exceptArrayPtr[range].codeOffset = startOffset;

    if (code != TCL_OK) {
	code = TCL_OUT_LINE_COMPILE;




	goto done;
    }
    envPtr->exceptArrayPtr[range].numCodeBytes =
	    (envPtr->codeNext - envPtr->codeStart) - startOffset;
		    
    /*
     * The "no errors" epilogue code: store the body's result into the
     * variable (if any), push "0" (TCL_OK) as the catch's "no error"
     * result, and jump around the "error case" code.
     */

    if (localIndex != -1) {
	if (localIndex <= 255) {
	    TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
	} else {
	    TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
	}
    }
    TclEmitOpcode(INST_POP, envPtr);
    TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);

    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);

    /*
     * The "error case" code: store the body's result into the variable (if
     * any), then push the error result code. The initial PC offset here is
     * the catch's error target.
     */
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
	    (envPtr->codeNext - envPtr->codeStart);
    
    /*
     * The for command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
    code = TCL_OK;

    done:
    envPtr->exceptDepth--;
    return code;
}








|







664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	    (envPtr->codeNext - envPtr->codeStart);
    
    /*
     * The for command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    code = TCL_OK;

    done:
    envPtr->exceptDepth--;
    return code;
}

698
699
700
701
702
703
704
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
 *	should be compiled "out of line" by emitting code to invoke its
 *	command procedure at runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "foreach" command
 *	at runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileForeachCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Proc *procPtr = envPtr->procPtr;
    ForeachInfo *infoPtr;	/* Points to the structure describing this
				 * foreach command. Stored in a AuxData
				 * record in the ByteCode. */
    int firstValueTemp;		/* Index of the first temp var in the frame
				 * used to point to a value list. */
    int loopCtTemp;		/* Index of temp var holding the loop's
				 * iteration count. */
    Tcl_Token *tokenPtr, *bodyTokenPtr;
    char *varList;
    unsigned char *jumpPc;
    JumpFixup jumpFalseFixup;
    int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
    int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
    char savedChar;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;


    /*
     * We parse the variable list argument words and create two arrays:
     *    varcList[i] is number of variables in i-th var list
     *    varvList[i] points to array of var names in i-th var list
     */








|


















<




<


<







692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717

718
719
720
721

722
723

724
725
726
727
728
729
730
 *	should be compiled "out of line" by emitting code to invoke its
 *	command procedure at runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "foreach" command
 *	at runtime.
 *
n*----------------------------------------------------------------------
 */

int
TclCompileForeachCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Proc *procPtr = envPtr->procPtr;
    ForeachInfo *infoPtr;	/* Points to the structure describing this
				 * foreach command. Stored in a AuxData
				 * record in the ByteCode. */
    int firstValueTemp;		/* Index of the first temp var in the frame
				 * used to point to a value list. */
    int loopCtTemp;		/* Index of temp var holding the loop's
				 * iteration count. */
    Tcl_Token *tokenPtr, *bodyTokenPtr;

    unsigned char *jumpPc;
    JumpFixup jumpFalseFixup;
    int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
    int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;

    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;


    /*
     * We parse the variable list argument words and create two arrays:
     *    varcList[i] is number of variables in i-th var list
     *    varvList[i] points to array of var names in i-th var list
     */

776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
    /*
     * 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(char **));
    }
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
        varcList[loopIndex] = 0;
        varvList[loopIndex] = NULL;
    }
    
    /*







|







767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
    /*
     * Allocate storage for the varcList and varvList arrays if necessary.
     */

    numLists = (numWords - 2)/2;
    if (numLists > STATIC_VAR_LIST_SIZE) {
        varcList = (int *) ckalloc(numLists * sizeof(int));
        varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
    }
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
        varcList[loopIndex] = 0;
        varvList[loopIndex] = NULL;
    }
    
    /*
805
806
807
808
809
810
811



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
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr += (tokenPtr->numComponents + 1)) {
	if (i%2 == 1) {
	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		code = TCL_OUT_LINE_COMPILE;
		goto done;



	    }
	    varList = tokenPtr[1].start;
	    savedChar = varList[tokenPtr[1].size];

	    /*
	     * Note there is a danger that modifying the string could have
	     * undesirable side effects.  In this case, Tcl_SplitList does
	     * not have any dependencies on shared strings so we should be
	     * safe.
	     */

	    varList[tokenPtr[1].size] = '\0';
	    code = Tcl_SplitList(interp, varList,
		    &varcList[loopIndex], &varvList[loopIndex]);
	    varList[tokenPtr[1].size] = savedChar;
	    if (code != TCL_OK) {
		goto done;
	    }

	    numVars = varcList[loopIndex];
	    for (j = 0;  j < numVars;  j++) {
		CONST char *varName = varvList[loopIndex][j];
		if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
		    code = TCL_OUT_LINE_COMPILE;
		    goto done;

		}
	    }
	    loopIndex++;
	}
    }

    /*







>
>
>
|
|
<

<
|
<
<
<
<
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
>







796
797
798
799
800
801
802
803
804
805
806
807

808

809




810
811
812
813
814
815
816
817

818
819
820
821
822
823
824
825
826
827
828
829
830
831
    for (i = 0, tokenPtr = parsePtr->tokenPtr;
	    i < numWords-1;
	    i++, tokenPtr += (tokenPtr->numComponents + 1)) {
	if (i%2 == 1) {
	    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		code = TCL_OUT_LINE_COMPILE;
		goto done;
	    } else {
		/* Lots of copying going on here.  Need a ListObj wizard
		 * to show a better way. */

		Tcl_DString varList;



		Tcl_DStringInit(&varList);




		Tcl_DStringAppend(&varList, tokenPtr[1].start,
			tokenPtr[1].size);
		code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
			&varcList[loopIndex], &varvList[loopIndex]);
		Tcl_DStringFree(&varList);
		if (code != TCL_OK) {
		    goto done;
		}

		numVars = varcList[loopIndex];
		for (j = 0;  j < numVars;  j++) {
		    CONST char *varName = varvList[loopIndex][j];
		    if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
			code = TCL_OUT_LINE_COMPILE;
			goto done;
		    }
		}
	    }
	    loopIndex++;
	}
    }

    /*
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
	    (envPtr->codeNext - envPtr->codeStart);
    
    /*
     * The foreach command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    done:
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
        if (varvList[loopIndex] != NULL) {
            ckfree((char *) varvList[loopIndex]);
        }
    }
    if (varcList != varcListStaticSpace) {
	ckfree((char *) varcList);
        ckfree((char *) varvList);
    }
    envPtr->exceptDepth--;
    return code;







|




|
|
|







993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
	    (envPtr->codeNext - envPtr->codeStart);
    
    /*
     * The foreach command's result is an empty string.
     */

    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    envPtr->currStackDepth = savedStackDepth + 1;

    done:
    for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
	if (varvList[loopIndex] != (CONST char **) NULL) {
	    ckfree((char *) varvList[loopIndex]);
	}
    }
    if (varcList != varcListStaticSpace) {
	ckfree((char *) varcList);
        ckfree((char *) varvList);
    }
    envPtr->exceptDepth--;
    return code;
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
				/* Used to fix the jump after each "then"
				 * body to the end of the "if" when that PC
				 * is determined. */
    Tcl_Token *tokenPtr, *testTokenPtr;
    int jumpDist, jumpFalseDist;
    int jumpIndex = 0;          /* avoid compiler warning. */
    int numWords, wordIdx, numBytes, j, code;
    char *word;
    char buffer[100];
    int savedStackDepth = envPtr->currStackDepth;
                                /* Saved stack depth at the start of the first
				 * test; the envPtr current depth is restored
				 * to this value at the start of each test. */
    char *condStart, *savedPos, savedChar;
    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]







|





<







1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154
1155
1156
1157
				/* Used to fix the jump after each "then"
				 * body to the end of the "if" when that PC
				 * is determined. */
    Tcl_Token *tokenPtr, *testTokenPtr;
    int jumpDist, jumpFalseDist;
    int jumpIndex = 0;          /* avoid compiler warning. */
    int numWords, wordIdx, numBytes, j, code;
    CONST char *word;
    char buffer[100];
    int savedStackDepth = envPtr->currStackDepth;
                                /* Saved stack depth at the start of the first
				 * test; the envPtr current depth is restored
				 * to this value at the start of each test. */

    int realCond = 1;           /* set to 0 for static conditions: "if 0 {..}" */
    int boolVal;                /* value of static condition */
    int compileScripts = 1;            

    /*
     * Only compile the "if" command if all arguments are simple
     * words, in order to insure correct substitution [Bug 219166]
1227
1228
1229
1230
1231
1232
1233
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


	if (realCond) {
	    /*
	     * Find out if the condition is a constant. 
	     */
	
	    condStart = testTokenPtr[1].start;
	    savedPos = condStart + testTokenPtr[1].size - 1;
	    
	    while (*condStart == ' ') {
		condStart++;
	    }
	    while (*savedPos == ' ') {
		savedPos--;
	    }
	    savedPos++;
	    
	    savedChar = *savedPos;
	    *savedPos = '\0';
	    
	    if (Tcl_GetBoolean(interp, condStart, &boolVal) != TCL_ERROR) { 
		/*
		 * A static condition
		 */
		*savedPos = savedChar;
		realCond = 0;
		if (!boolVal) {
		    compileScripts = 0;
		}
	    } else {
		*savedPos = savedChar;
		Tcl_ResetResult(interp);
		code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
		if (code != TCL_OK) {
		    if (code == TCL_ERROR) {
			Tcl_AddObjErrorInfo(interp,
			        "\n    (\"if\" test expression)", -1);
		    }







|
|
|
<
<
<
<
<
<
<
|
<
<
|
|



<





<







1214
1215
1216
1217
1218
1219
1220
1221
1222
1223







1224


1225
1226
1227
1228
1229

1230
1231
1232
1233
1234

1235
1236
1237
1238
1239
1240
1241


	if (realCond) {
	    /*
	     * Find out if the condition is a constant. 
	     */
	
	    Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
		    testTokenPtr[1].size);
	    Tcl_IncrRefCount(boolObj);







	    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);


	    Tcl_DecrRefCount(boolObj);
	    if (code == TCL_OK) {
		/*
		 * A static condition
		 */

		realCond = 0;
		if (!boolVal) {
		    compileScripts = 0;
		}
	    } else {

		Tcl_ResetResult(interp);
		code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
		if (code != TCL_OK) {
		    if (code == TCL_ERROR) {
			Tcl_AddObjErrorInfo(interp,
			        "\n    (\"if\" test expression)", -1);
		    }
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
	}
    } else {
	/*
	 * No else clause: the "if" command's result is an empty string.
	 */

	if (compileScripts) {
	    TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr);
	}
    }

    /*
     * Fix the unconditional jumps to the end of the "if" command.
     */
    







|







1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
	}
    } else {
	/*
	 * No else clause: the "if" command's result is an empty string.
	 */

	if (compileScripts) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
	}
    }

    /*
     * Fix the unconditional jumps to the end of the "if" command.
     */
    
1530
1531
1532
1533
1534
1535
1536
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
	        "wrong # args: should be \"incr varName ?increment?\"", -1);
	return TCL_ERROR;
    }

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,

	    &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
	goto done;
    }

    /*
     * If an increment is given, push it, but see first if it's a small
     * integer.
     */

    haveImmValue = 0;
    immValue = 0;
    if (parsePtr->numWords == 3) {
	incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    char *word = incrTokenPtr[1].start;
	    int numBytes = incrTokenPtr[1].size;
	    char savedChar = word[numBytes];
	    long n;

	    /*
	     * Note there is a danger that modifying the string could have
	     * undesirable side effects.  In this case, TclLooksLikeInt and
	     * TclGetLong do not have any dependencies on shared strings so we
	     * should be safe.
	     */

	    word[numBytes] = '\0';

	    if (TclLooksLikeInt(word, numBytes)
		    && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {


		if ((-127 <= n) && (n <= 127)) {
		    haveImmValue = 1;
		    immValue = n;
		}
	    }
	    word[numBytes] = savedChar;
	    if (!haveImmValue) {
		TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes,
	               /*onHeap*/ 0), envPtr);
	    }
	} else {
	    code = TclCompileTokens(interp, incrTokenPtr+1, 
	            incrTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    Tcl_AddObjErrorInfo(interp,







|
>















|

|









|
>
|
|
>
>
|




<

|
|







1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552

1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
	        "wrong # args: should be \"incr varName ?increment?\"", -1);
	return TCL_ERROR;
    }

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, 
	    (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
	    &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
	goto done;
    }

    /*
     * If an increment is given, push it, but see first if it's a small
     * integer.
     */

    haveImmValue = 0;
    immValue = 0;
    if (parsePtr->numWords == 3) {
	incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    CONST char *word = incrTokenPtr[1].start;
	    int numBytes = incrTokenPtr[1].size;
	    int validLength = TclParseInteger(word, numBytes);
	    long n;

	    /*
	     * Note there is a danger that modifying the string could have
	     * undesirable side effects.  In this case, TclLooksLikeInt and
	     * TclGetLong do not have any dependencies on shared strings so we
	     * should be safe.
	     */

	    if (validLength == numBytes) {
		int code;
		Tcl_Obj *longObj = Tcl_NewStringObj(word, numBytes);
		Tcl_IncrRefCount(longObj);
		code = Tcl_GetLongFromObj(NULL, longObj, &n);
		Tcl_DecrRefCount(longObj);
		if ((code == TCL_OK) && (-127 <= n) && (n <= 127)) {
		    haveImmValue = 1;
		    immValue = n;
		}
	    }

	    if (!haveImmValue) {
		TclEmitPush(
			TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
	    }
	} else {
	    code = TclCompileTokens(interp, incrTokenPtr+1, 
	            incrTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		if (code == TCL_ERROR) {
		    Tcl_AddObjErrorInfo(interp,
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
     * If we are doing an assignment, push the new value.
     * In the no values case, create an empty object.
     */

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,
		    valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);
	} else {
	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
#if 0
    } else {
	/*
	 * We need to carefully handle the two arg case, as lappend
	 * always creates the variable.
	 */

	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
	numValues = 1;
#endif
    }

    /*
     * Emit instructions to set/get the variable.
     */







|
|














|







1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
     * If we are doing an assignment, push the new value.
     * In the no values case, create an empty object.
     */

    if (numWords > 2) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, 
		    valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
	} else {
	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
#if 0
    } else {
	/*
	 * We need to carefully handle the two arg case, as lappend
	 * always creates the variable.
	 */

	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
	numValues = 1;
#endif
    }

    /*
     * Emit instructions to set/get the variable.
     */
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
    
    /*
     * Push the operands onto the stack.
     */
	
    for ( i = 1 ; i < numWords ; i++ ) {
	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush( TclRegisterLiteral( envPtr,
					     varTokenPtr[1].start,
					     varTokenPtr[1].size,
					     0),
			 envPtr);
	} else {
	    code = TclCompileTokens(interp, varTokenPtr+1,
				    varTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		return code;
	    }
	}







|
|
|
<
<







1805
1806
1807
1808
1809
1810
1811
1812
1813
1814


1815
1816
1817
1818
1819
1820
1821
    
    /*
     * Push the operands onto the stack.
     */
	
    for ( i = 1 ; i < numWords ; i++ ) {
	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(
		    TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);


	} else {
	    code = TclCompileTokens(interp, varTokenPtr+1,
				    varTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		return code;
	    }
	}
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
    }

    if (parsePtr->numWords == 1) {
	/*
	 * Empty args case
	 */

	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, 0), envPtr);
    } else {
	/*
	 * Push the all values onto the stack.
	 */
	Tcl_Token *valueTokenPtr;
	int i, code, numWords;

	numWords = parsePtr->numWords;

	valueTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
	for (i = 1; i < numWords; i++) {
	    if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		TclEmitPush(TclRegisterLiteral(envPtr,
			valueTokenPtr[1].start, valueTokenPtr[1].size,
			/*onHeap*/ 0), envPtr);
	    } else {
		code = TclCompileTokens(interp, valueTokenPtr+1,
			valueTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }







|













|
|
<







1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896

1897
1898
1899
1900
1901
1902
1903
    }

    if (parsePtr->numWords == 1) {
	/*
	 * Empty args case
	 */

	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    } else {
	/*
	 * Push the all values onto the stack.
	 */
	Tcl_Token *valueTokenPtr;
	int i, code, numWords;

	numWords = parsePtr->numWords;

	valueTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
	for (i = 1; i < numWords; i++) {
	    if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		TclEmitPush(TclRegisterNewLiteral(envPtr,
			valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);

	    } else {
		code = TclCompileTokens(interp, valueTokenPtr+1,
			valueTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
	+ (parsePtr->tokenPtr->numComponents + 1);

    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * We could simply count the number of elements here and push
	 * that value, but that is too rare a case to waste the code space.
	 */
	TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start,
		varTokenPtr[1].size, 0), envPtr);
    } else {
	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }







|
|







1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
	+ (parsePtr->tokenPtr->numComponents + 1);

    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	/*
	 * We could simply count the number of elements here and push
	 * that value, but that is too rare a case to waste the code space.
	 */
	TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
		varTokenPtr[1].size), envPtr);
    } else {
	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }
2068
2069
2070
2071
2072
2073
2074
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
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    result = TclPushVarName( interp, varTokenPtr, envPtr, 0,
			     &localIndex, &simpleVarName, &isScalar );
    if (result != TCL_OK) {
	return result;
    }

    /* Push the "index" args and the new element value. */

    for ( i = 2; i < parsePtr->numWords; ++i ) {

	/* Advance to next arg */

	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

	/* Push an arg */

	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush( TclRegisterLiteral( envPtr,
					     varTokenPtr[1].start,
					     varTokenPtr[1].size,
					     0),
			 envPtr);
	} else {
	    result = TclCompileTokens(interp, varTokenPtr+1,
				      varTokenPtr->numComponents, envPtr);
	    if ( result != TCL_OK ) {
		return result;
	    }
	}







|
|















<
|
|
<
<







2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067

2068
2069


2070
2071
2072
2073
2074
2075
2076
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);
    result = TclPushVarName( interp, varTokenPtr, envPtr, 
            TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
    if (result != TCL_OK) {
	return result;
    }

    /* Push the "index" args and the new element value. */

    for ( i = 2; i < parsePtr->numWords; ++i ) {

	/* Advance to next arg */

	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);

	/* Push an arg */

	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {

	    TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
		    varTokenPtr[1].size), envPtr);


	} else {
	    result = TclCompileTokens(interp, varTokenPtr+1,
				      varTokenPtr->numComponents, envPtr);
	    if ( result != TCL_OK ) {
		return result;
	    }
	}
2219
2220
2221
2222
2223
2224
2225

2226
2227
2228
2229
2230
2231
2232
2233
    Tcl_Parse* parsePtr;	/* Points to a parse structure for
				 * the command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    Tcl_Token *varTokenPtr;	/* Pointer to the Tcl_Token representing
				 * the parse of the RE or string */
    int i, len, code, exactMatch, nocase;

    char c, *str;

    /*
     * We are only interested in compiling simple regexp cases.
     * Currently supported compile cases are:
     *   regexp ?-nocase? ?--? staticString $var
     *   regexp ?-nocase? ?--? {^staticString$} $var
     */







>
|







2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
    Tcl_Parse* parsePtr;	/* Points to a parse structure for
				 * the command */
    CompileEnv* envPtr;		/* Holds the resulting instructions */
{
    Tcl_Token *varTokenPtr;	/* Pointer to the Tcl_Token representing
				 * the parse of the RE or string */
    int i, len, code, exactMatch, nocase;
    Tcl_Obj *patternObj;
    CONST char *str;

    /*
     * We are only interested in compiling simple regexp cases.
     * Currently supported compile cases are:
     *   regexp ?-nocase? ?--? staticString $var
     *   regexp ?-nocase? ?--? {^staticString$} $var
     */
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
	return TCL_OUT_LINE_COMPILE;
    }

    if (len == 0) {
	/*
	 * The semantics of regexp are always match on re == "".
	 */
	TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, 0), envPtr);
	return TCL_OK;
    }

    /*
     * On the first (pattern) arg, check to see if any RE special characters
     * are in the word.  If not, this is the same as 'string equal'.
     * We can use strchr here because the glob chars are all in the ascii-7







|







2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
	return TCL_OUT_LINE_COMPILE;
    }

    if (len == 0) {
	/*
	 * The semantics of regexp are always match on re == "".
	 */
	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
	return TCL_OK;
    }

    /*
     * On the first (pattern) arg, check to see if any RE special characters
     * are in the word.  If not, this is the same as 'string equal'.
     * We can use strchr here because the glob chars are all in the ascii-7
2317
2318
2319
2320
2321
2322
2323
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
	 * off the special chars and signal exactMatch.
	 */
	str++; len -= 2;
	exactMatch = 1;
    } else {
	exactMatch = 0;
    }
    c = str[len];
    str[len] = '\0';

    if (strpbrk(str, "*+?{}()[].\\|^$") != NULL) {
	str[len] = c;


	/* We don't do anything with REs with special chars yet. */
	return TCL_OUT_LINE_COMPILE;
    }
    str[len] = c;
    if (exactMatch) {
	TclEmitPush(TclRegisterLiteral(envPtr, str, len, 0), envPtr);
    } else {
	/*
	 * This needs to find the substring anywhere in the string, so
	 * use string match and *foo*.
	 */
	char *newStr  = ckalloc((unsigned) len + 3);
	newStr[0]     = '*';
	strncpy(newStr + 1, str, (size_t) len);
	newStr[len+1] = '*';
	newStr[len+2] = '\0';
	TclEmitPush(TclRegisterLiteral(envPtr, newStr, len+2, 0), envPtr);
	ckfree((char *) newStr);
    }

    /*
     * Push the string arg
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitPush(TclRegisterLiteral(envPtr,
		varTokenPtr[1].start, varTokenPtr[1].size, 0), envPtr);
    } else {
	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }







|
|
>
|
<
>
>



<

|










|








|
|







2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301

2302
2303
2304
2305
2306

2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
	 * off the special chars and signal exactMatch.
	 */
	str++; len -= 2;
	exactMatch = 1;
    } else {
	exactMatch = 0;
    }
    
    patternObj = Tcl_NewStringObj(str, len);
    Tcl_IncrRefCount(patternObj);
    code = (strpbrk(Tcl_GetString(patternObj), "*+?{}()[].\\|^$") != NULL);

    Tcl_DecrRefCount(patternObj);
    if (code) {
	/* We don't do anything with REs with special chars yet. */
	return TCL_OUT_LINE_COMPILE;
    }

    if (exactMatch) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, str, len), envPtr);
    } else {
	/*
	 * This needs to find the substring anywhere in the string, so
	 * use string match and *foo*.
	 */
	char *newStr  = ckalloc((unsigned) len + 3);
	newStr[0]     = '*';
	strncpy(newStr + 1, str, (size_t) len);
	newStr[len+1] = '*';
	newStr[len+2] = '\0';
	TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len+2), envPtr);
	ckfree((char *) newStr);
    }

    /*
     * Push the string arg
     */
    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	TclEmitPush(TclRegisterNewLiteral(envPtr,
		varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
    } else {
	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    return code;
	}
    }
2412
2413
2414
2415
2416
2417
2418
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

    switch (parsePtr->numWords) {
	case 1: {
	    /*
	     * Simple case:  [return]
	     * Just push the literal string "".
	     */
	    TclEmitPush(TclRegisterLiteral(envPtr, "", 0, 0), envPtr);
	    break;
	}
	case 2: {
	    /*
	     * More complex cases:
	     * [return "foo"]
	     * [return $value]
	     * [return [otherCmd]]
	     */
	    varTokenPtr = parsePtr->tokenPtr
		+ (parsePtr->tokenPtr->numComponents + 1);
	    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		/*
		 * [return "foo"] case:  the parse token is a simple word,
		 * so just push it.
		 */
		TclEmitPush(TclRegisterLiteral(envPtr, varTokenPtr[1].start,
			varTokenPtr[1].size, /*onHeap*/ 0), envPtr);
	    } else {
		/*
		 * Parse token is more complex, so compile it; this handles the
		 * variable reference and nested command cases.  If the
		 * parse token can be byte-compiled, then this instance of
		 * "return" will be byte-compiled; otherwise it will be
		 * out line compiled.







|
















|
|







2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419

    switch (parsePtr->numWords) {
	case 1: {
	    /*
	     * Simple case:  [return]
	     * Just push the literal string "".
	     */
	    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
	    break;
	}
	case 2: {
	    /*
	     * More complex cases:
	     * [return "foo"]
	     * [return $value]
	     * [return [otherCmd]]
	     */
	    varTokenPtr = parsePtr->tokenPtr
		+ (parsePtr->tokenPtr->numComponents + 1);
	    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		/*
		 * [return "foo"] case:  the parse token is a simple word,
		 * so just push it.
		 */
		TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
			varTokenPtr[1].size), envPtr);
	    } else {
		/*
		 * Parse token is more complex, so compile it; this handles the
		 * variable reference and nested command cases.  If the
		 * parse token can be byte-compiled, then this instance of
		 * "return" will be byte-compiled; otherwise it will be
		 * out line compiled.
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr,
	    (isAssignment ? TCL_CREATE_VAR : 0),
	    &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
	goto done;
    }

    /*
     * If we are doing an assignment, push the new value.
     */

    if (isAssignment) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,
		    valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);
	} else {
	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}







|
<












|
|







2494
2495
2496
2497
2498
2499
2500
2501

2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
     */

    varTokenPtr = parsePtr->tokenPtr
	    + (parsePtr->tokenPtr->numComponents + 1);

    code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,

	    &localIndex, &simpleVarName, &isScalar);
    if (code != TCL_OK) {
	goto done;
    }

    /*
     * If we are doing an assignment, push the new value.
     */

    if (isAssignment) {
	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
		    valueTokenPtr[1].size), envPtr);
	} else {
	    code = TclCompileTokens(interp, valueTokenPtr+1,
	            valueTokenPtr->numComponents, envPtr);
	    if (code != TCL_OK) {
		goto done;
	    }
	}
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712

	    /*
	     * Push the two operands onto the stack.
	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size,
			    0), envPtr);
		} else {
		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}







|
|
<







2670
2671
2672
2673
2674
2675
2676
2677
2678

2679
2680
2681
2682
2683
2684
2685

	    /*
	     * Push the two operands onto the stack.
	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size), envPtr);

		} else {
		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743

	    /*
	     * Push the two operands onto the stack.
	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size,
			    0), envPtr);
		} else {
		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}







|
|
<







2700
2701
2702
2703
2704
2705
2706
2707
2708

2709
2710
2711
2712
2713
2714
2715

	    /*
	     * Push the two operands onto the stack.
	     */

	    for (i = 0; i < 2; i++) {
		if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr,
			    varTokenPtr[1].start, varTokenPtr[1].size), envPtr);

		} else {
		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
		 * Here someone is asking for the length of a static string.
		 * Just push the actual character (not byte) length.
		 */
		char buf[TCL_INTEGER_SPACE];
		int len = Tcl_NumUtfChars(varTokenPtr[1].start,
			varTokenPtr[1].size);
		len = sprintf(buf, "%d", len);
		TclEmitPush(TclRegisterLiteral(envPtr, buf, len, 0), envPtr);
		return TCL_OK;
	    } else {
		code = TclCompileTokens(interp, varTokenPtr+1,
			varTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
	    TclEmitOpcode(INST_STR_LEN, envPtr);
	    return TCL_OK;
	}
	case STR_MATCH: {
	    int i, length, exactMatch = 0, nocase = 0;
	    char c, *str;

	    if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
		/* Fail at run time, not in compilation */
		return TCL_OUT_LINE_COMPILE;
	    }

	    if (parsePtr->numWords == 5) {







|













|







2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
		 * Here someone is asking for the length of a static string.
		 * Just push the actual character (not byte) length.
		 */
		char buf[TCL_INTEGER_SPACE];
		int len = Tcl_NumUtfChars(varTokenPtr[1].start,
			varTokenPtr[1].size);
		len = sprintf(buf, "%d", len);
		TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
		return TCL_OK;
	    } else {
		code = TclCompileTokens(interp, varTokenPtr+1,
			varTokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    return code;
		}
	    }
	    TclEmitOpcode(INST_STR_LEN, envPtr);
	    return TCL_OK;
	}
	case STR_MATCH: {
	    int i, length, exactMatch = 0, nocase = 0;
	    CONST char *str;

	    if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
		/* Fail at run time, not in compilation */
		return TCL_OUT_LINE_COMPILE;
	    }

	    if (parsePtr->numWords == 5) {
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819

2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
		    str = varTokenPtr[1].start;
		    length = varTokenPtr[1].size;
		    if (!nocase && (i == 0)) {
			/*
			 * On the first (pattern) arg, check to see if any
			 * glob special characters are in the word '*[]?\\'.
			 * If not, this is the same as 'string equal'.  We
			 * can use strchr here because the glob chars are all
			 * in the ascii-7 range.  If -nocase was specified,
			 * we can't do this because INST_STR_EQ has no support
			 * for nocase.
			 */
			c = str[length];
			str[length] = '\0';
			exactMatch = (strpbrk(str, "*[]?\\") == NULL);
			str[length] = c;

		    }
		    TclEmitPush(TclRegisterLiteral(envPtr, str, length,
			    0), envPtr);
		} else {
		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}







|




|
|
|
|
>

|
|







2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
		    str = varTokenPtr[1].start;
		    length = varTokenPtr[1].size;
		    if (!nocase && (i == 0)) {
			/*
			 * On the first (pattern) arg, check to see if any
			 * glob special characters are in the word '*[]?\\'.
			 * If not, this is the same as 'string equal'.  We
			 * can use strpbrk here because the glob chars are all
			 * in the ascii-7 range.  If -nocase was specified,
			 * we can't do this because INST_STR_EQ has no support
			 * for nocase.
			 */
			Tcl_Obj *copy = Tcl_NewStringObj(str, length);
			Tcl_IncrRefCount(copy);
			exactMatch = (strpbrk(Tcl_GetString(copy),
				"*[]?\\") == NULL);
			Tcl_DecrRefCount(copy);
		    }
		    TclEmitPush(
			    TclRegisterNewLiteral(envPtr, str, length), envPtr);
		} else {
		    code = TclCompileTokens(interp, varTokenPtr+1,
			    varTokenPtr->numComponents, envPtr);
		    if (code != TCL_OK) {
			return code;
		    }
		}
2837
2838
2839
2840
2841
2842
2843






















































2844
2845
2846
2847
2848
2849
2850
	    }
	    return TCL_OK;
	}
    }

    return TCL_OK;
}























































/*
 *----------------------------------------------------------------------
 *
 * TclCompileWhileCmd --
 *
 *	Procedure called to compile the "while" command.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
	    }
	    return TCL_OK;
	}
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileVariableCmd --
 *
 *	Procedure called to reserve the local variables for the 
 *      "variable" command. The command itself is *not* compiled.
 *
 * Results:
 *      Always returns TCL_OUT_LINE_COMPILE.
 *
 * Side effects:
 *      Indexed local variables are added to the environment.
 *
 *----------------------------------------------------------------------
 */
int
TclCompileVariableCmd(interp, parsePtr, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Points to a parse structure for the
				 * command created by Tcl_ParseCommand. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Token *varTokenPtr;
    int i, numWords;
    CONST char *varName, *tail;
    
    if (envPtr->procPtr == NULL) {
	return TCL_OUT_LINE_COMPILE;
    }

    numWords = parsePtr->numWords;
    
    varTokenPtr = parsePtr->tokenPtr
	+ (parsePtr->tokenPtr->numComponents + 1);
    for (i = 1; i < numWords; i += 2) {
	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
	    varName = varTokenPtr[1].start;
	    tail = varName + varTokenPtr[1].size - 1;
	    if ((*tail == ')') || (tail < varName)) continue;
	    while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
		tail--;
	    }
	    if ((*tail == ':') && (tail > varName)) {
		tail++;
	    }
	    (void) TclFindCompiledLocal(tail, (tail-varName+1),
		    /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
	    varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
	}
    }
    return TCL_OUT_LINE_COMPILE;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileWhileCmd --
 *
 *	Procedure called to compile the "while" command.
2876
2877
2878
2879
2880
2881
2882

2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, jumpDist;
    int range, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;
    int loopMayEnd = 1;         /* This is set to 0 if it is recognized as
				 * an infinite loop. */

    int boolVal;
    char *condStart;
    char savedChar, *savedPos;

    if (parsePtr->numWords != 3) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"while test command\"", -1);
	return TCL_ERROR;
    }







>

<
<







2903
2904
2905
2906
2907
2908
2909
2910
2911


2912
2913
2914
2915
2916
2917
2918
    JumpFixup jumpEvalCondFixup;
    int testCodeOffset, bodyCodeOffset, jumpDist;
    int range, code;
    char buffer[32 + TCL_INTEGER_SPACE];
    int savedStackDepth = envPtr->currStackDepth;
    int loopMayEnd = 1;         /* This is set to 0 if it is recognized as
				 * an infinite loop. */
    Tcl_Obj *boolObj;
    int boolVal;



    if (parsePtr->numWords != 3) {
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp),
	        "wrong # args: should be \"while test command\"", -1);
	return TCL_ERROR;
    }
2908
2909
2910
2911
2912
2913
2914
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
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Find out if the condition is a constant. 
     */

    condStart = testTokenPtr[1].start;
    savedPos = condStart + testTokenPtr[1].size - 1;

    while (*condStart == ' ') {
	condStart++;
    }
    while (*savedPos == ' ') {
	savedPos--;
    }
    savedPos++;

    savedChar = *savedPos;
    *savedPos = '\0';
    
    if (Tcl_GetBoolean(interp, condStart, &boolVal) != TCL_ERROR) { 
	if (boolVal) {
	    /*
	     * it is an infinite loop 
	     */

	    loopMayEnd = 0;  
	} else {
	    /*
	     * This is an empty loop: "while 0 {...}" or such.
	     * Compile no bytecodes.
	     */

	    *savedPos = savedChar;
	    goto pushResult;
	}
    } else {
	Tcl_ResetResult(interp);	
    }
    *savedPos = savedChar;
	
    /* 
     * Create a ExceptionRange record for the loop body. This is used to
     * implement break and continue.
     */

    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =







|
<
|
<
<
<
<
<
<
<
|
<
<
|
|












<


<
<

<
|







2934
2935
2936
2937
2938
2939
2940
2941

2942







2943


2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957

2958
2959


2960

2961
2962
2963
2964
2965
2966
2967
2968
	return TCL_OUT_LINE_COMPILE;
    }

    /*
     * Find out if the condition is a constant. 
     */

    boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);

    Tcl_IncrRefCount(boolObj);







    code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);


    Tcl_DecrRefCount(boolObj);
    if (code == TCL_OK) {
	if (boolVal) {
	    /*
	     * it is an infinite loop 
	     */

	    loopMayEnd = 0;  
	} else {
	    /*
	     * This is an empty loop: "while 0 {...}" or such.
	     * Compile no bytecodes.
	     */


	    goto pushResult;
	}


    }


    /* 
     * Create a ExceptionRange record for the loop body. This is used to
     * implement break and continue.
     */

    envPtr->exceptDepth++;
    envPtr->maxExceptDepth =
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
    
    /*
     * The while command's result is an empty string.
     */

    pushResult:
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
    envPtr->exceptDepth--;
    return TCL_OK;

    error:
    envPtr->exceptDepth--;
    return code;
}







|







3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
    
    /*
     * The while command's result is an empty string.
     */

    pushResult:
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    envPtr->exceptDepth--;
    return TCL_OK;

    error:
    envPtr->exceptDepth--;
    return code;
}
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103



3104
3105
3106
3107
3108
3109
3110
static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
	simpleVarNamePtr, isScalarPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Token *varTokenPtr;	/* Points to a variable token. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    int flags;			/* takes TCL_CREATE_VAR or
				 * TCL_LARGE_INDEX_OK */
    int *localIndexPtr;		/* must not be NULL */
    int *simpleVarNamePtr;	/* must not be NULL */
    int *isScalarPtr;		/* must not be NULL */
{
    Tcl_Parse elemParse;
    int gotElemParse = 0;
    register char *p;
    char *name, *elName;
    register int i, n;
    int nameChars, elNameChars, simpleVarName, localIndex;
    int code = TCL_OK;




    /*
     * 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. 







|






|
|



>
>
>







3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
	simpleVarNamePtr, isScalarPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Token *varTokenPtr;	/* Points to a variable token. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    int flags;			/* takes TCL_CREATE_VAR or
				 * TCL_NO_LARGE_INDEX */
    int *localIndexPtr;		/* must not be NULL */
    int *simpleVarNamePtr;	/* must not be NULL */
    int *isScalarPtr;		/* must not be NULL */
{
    Tcl_Parse elemParse;
    int gotElemParse = 0;
    register CONST char *p;
    CONST char *name, *elName;
    register int i, n;
    int nameChars, elNameChars, simpleVarName, localIndex;
    int code = TCL_OK;
    Tcl_DString copy;

    Tcl_DStringInit(&copy);

    /*
     * Decide if we can use a frame slot for the var/array name or if we
     * need to emit code to compute and push the name at runtime. We use a
     * frame slot (entry in the array of local vars) if we are compiling a
     * procedure body and if the name is simple text that does not include
     * namespace qualifiers. 
3220
3221
3222
3223
3224
3225
3226
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
		    envPtr->procPtr);
	    if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
		/* we'll push the name */
		localIndex = -1;
	    }
	}
	if (localIndex < 0) {
	    TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
		    /*onHeap*/ 0), envPtr);
	}

	/*
	 * Compile the element script, if any.
	 */

	if (elName != NULL) {
	    /*
	     * Temporarily replace the '(' and ')' by '"'s.
	     */

	    *(elName-1) = '"';
	    *(elName+elNameChars) = '"';
	    code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
                    /*nested*/ 0, &elemParse);
	    *(elName-1) = '(';
	    *(elName+elNameChars) = ')';
	    gotElemParse = 1;
	    if ((code != TCL_OK) || (elemParse.numWords > 1)) {
		char buffer[160];
		sprintf(buffer, "\n    (parsing index for array \"%.*s\")",
		        TclMin(nameChars, 100), name);
		Tcl_AddObjErrorInfo(interp, buffer, -1);
		code = TCL_ERROR;
		goto done;
	    } else if (elemParse.numWords == 1) {
		code = TclCompileTokens(interp, elemParse.tokenPtr+1,
                        elemParse.tokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    goto done;
		}
	    } else {
		TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
                        /*alreadyAlloced*/ 0), envPtr);
	    }
	}
    } else {
	/*
	 * The var name isn't simple: compile and push it.
	 */

	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    goto done;
	}
    }

    done:
    if (gotElemParse) {
        Tcl_FreeParse(&elemParse);
    }

    *localIndexPtr	= localIndex;
    *simpleVarNamePtr	= simpleVarName;
    *isScalarPtr	= (elName == NULL);
    return code;
}







|
<










|
|
|
|
|
<
<















|
<


















>





3235
3236
3237
3238
3239
3240
3241
3242

3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257


3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273

3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
		    envPtr->procPtr);
	    if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
		/* we'll push the name */
		localIndex = -1;
	    }
	}
	if (localIndex < 0) {
	    TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);

	}

	/*
	 * Compile the element script, if any.
	 */

	if (elName != NULL) {
	    /*
	     * Temporarily replace the '(' and ')' by '"'s.
	     */
	    Tcl_DStringAppend(&copy, "\"", 1);
	    Tcl_DStringAppend(&copy, elName, elNameChars);
	    Tcl_DStringAppend(&copy, "\"", 1);
	    code = Tcl_ParseCommand(interp, Tcl_DStringValue(&copy),
		    elNameChars+2, /*nested*/ 0, &elemParse);


	    gotElemParse = 1;
	    if ((code != TCL_OK) || (elemParse.numWords > 1)) {
		char buffer[160];
		sprintf(buffer, "\n    (parsing index for array \"%.*s\")",
		        TclMin(nameChars, 100), name);
		Tcl_AddObjErrorInfo(interp, buffer, -1);
		code = TCL_ERROR;
		goto done;
	    } else if (elemParse.numWords == 1) {
		code = TclCompileTokens(interp, elemParse.tokenPtr+1,
                        elemParse.tokenPtr->numComponents, envPtr);
		if (code != TCL_OK) {
		    goto done;
		}
	    } else {
		TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);

	    }
	}
    } else {
	/*
	 * The var name isn't simple: compile and push it.
	 */

	code = TclCompileTokens(interp, varTokenPtr+1,
		varTokenPtr->numComponents, envPtr);
	if (code != TCL_OK) {
	    goto done;
	}
    }

    done:
    if (gotElemParse) {
        Tcl_FreeParse(&elemParse);
    }
    Tcl_DStringFree(&copy);
    *localIndexPtr	= localIndex;
    *simpleVarNamePtr	= simpleVarName;
    *isScalarPtr	= (elName == NULL);
    return code;
}
Changes to generic/tclCompExpr.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclCompExpr.c --
 *
 *	This file contains the code to compile Tcl expressions.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompExpr.c,v 1.6.14.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * The stuff below is a bit of a hack so that this file can be used in











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclCompExpr.c --
 *
 *	This file contains the code to compile Tcl expressions.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompExpr.c,v 1.6.14.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * The stuff below is a bit of a hack so that this file can be used in
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
 * this module.
 */

typedef struct ExprInfo {
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Structure filled with information about
				 * the parsed expression. */
    char *expr;			/* The expression that was originally passed
				 * to TclCompileExpr. */
    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;








|

|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
 * this module.
 */

typedef struct ExprInfo {
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Parse *parsePtr;	/* Structure filled with information about
				 * the parsed expression. */
    CONST char *expr;		/* The expression that was originally passed
				 * to TclCompileExpr. */
    CONST char *lastChar;	/* Points just after last byte of expr. */
    int hasOperators;		/* Set 1 if the expr has operators; 0 if
				 * expr is only a primary. If 1 after
				 * compiling an expr, a tryCvtToNumeric
				 * instruction is emitted to convert the
				 * primary to a number if possible. */
} ExprInfo;

106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
    char *name;			/* Name of the operator. */
    int numOperands;		/* Number of operands. 0 if the operator
				 * requires special handling. */
    int instruction;		/* Instruction opcode for the operator.
				 * Ignored if numOperands is 0. */
} OperatorDesc;

OperatorDesc operatorTable[] = {
    {"*",   2,  INST_MULT},
    {"/",   2,  INST_DIV},
    {"%",   2,  INST_MOD},
    {"+",   0}, 
    {"-",   0},
    {"<<",  2,  INST_LSHIFT},
    {">>",  2,  INST_RSHIFT},







|







106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
    char *name;			/* Name of the operator. */
    int numOperands;		/* Number of operands. 0 if the operator
				 * requires special handling. */
    int instruction;		/* Instruction opcode for the operator.
				 * Ignored if numOperands is 0. */
} OperatorDesc;

static OperatorDesc operatorTable[] = {
    {"*",   2,  INST_MULT},
    {"/",   2,  INST_DIV},
    {"%",   2,  INST_MOD},
    {"+",   0}, 
    {"-",   0},
    {"<<",  2,  INST_LSHIFT},
    {">>",  2,  INST_RSHIFT},
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
			    Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
			    CompileEnv *envPtr, Tcl_Token **endPtrPtr));
static int		CompileLandOrLorExpr _ANSI_ARGS_((
			    Tcl_Token *exprTokenPtr, int opIndex,
			    ExprInfo *infoPtr, CompileEnv *envPtr,
			    Tcl_Token **endPtrPtr));
static int		CompileMathFuncCall _ANSI_ARGS_((
			    Tcl_Token *exprTokenPtr, char *funcName,
			    ExprInfo *infoPtr, CompileEnv *envPtr,
			    Tcl_Token **endPtrPtr));
static int		CompileSubExpr _ANSI_ARGS_((
			    Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
			    CompileEnv *envPtr));
static void		LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr));








|







152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
			    Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
			    CompileEnv *envPtr, Tcl_Token **endPtrPtr));
static int		CompileLandOrLorExpr _ANSI_ARGS_((
			    Tcl_Token *exprTokenPtr, int opIndex,
			    ExprInfo *infoPtr, CompileEnv *envPtr,
			    Tcl_Token **endPtrPtr));
static int		CompileMathFuncCall _ANSI_ARGS_((
			    Tcl_Token *exprTokenPtr, CONST char *funcName,
			    ExprInfo *infoPtr, CompileEnv *envPtr,
			    Tcl_Token **endPtrPtr));
static int		CompileSubExpr _ANSI_ARGS_((
			    Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
			    CompileEnv *envPtr));
static void		LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr));

199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
 *
 *----------------------------------------------------------------------
 */

int
TclCompileExpr(interp, script, numBytes, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    ExprInfo info;
    Tcl_Parse parse;







|







199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
 *
 *----------------------------------------------------------------------
 */

int
TclCompileExpr(interp, script, numBytes, envPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    ExprInfo info;
    Tcl_Parse parse;
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Interp *interp = infoPtr->interp;
    Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
    OperatorDesc *opDescPtr;
    Tcl_HashEntry *hPtr;
    char *operator;
    char savedChar;
    int objIndex, opIndex, length, code;
    char buffer[TCL_UTF_MAX];

    if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
	panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
	        exprTokenPtr->type);
    }







|
|







339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Tcl_Interp *interp = infoPtr->interp;
    Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
    OperatorDesc *opDescPtr;
    Tcl_HashEntry *hPtr;
    CONST char *operator;
    Tcl_DString opBuf;
    int objIndex, opIndex, length, code;
    char buffer[TCL_UTF_MAX];

    if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
	panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
	        exprTokenPtr->type);
    }
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_TEXT:
	    if (tokenPtr->size > 0) {
		objIndex = TclRegisterLiteral(envPtr, tokenPtr->start,
	                tokenPtr->size, /*onHeap*/ 0);
	    } else {
		objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
	    }
	    TclEmitPush(objIndex, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_BS:
	    length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
		    buffer);
	    if (length > 0) {
		objIndex = TclRegisterLiteral(envPtr, buffer, length,
	                /*onHeap*/ 0);
	    } else {
		objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
	    }
	    TclEmitPush(objIndex, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_COMMAND:
	    code = TclCompileScript(interp, tokenPtr->start+1,







|
|

|









|
<

|







371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391

392
393
394
395
396
397
398
399
400
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_TEXT:
	    if (tokenPtr->size > 0) {
		objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
	                tokenPtr->size);
	    } else {
		objIndex = TclRegisterNewLiteral(envPtr, "", 0);
	    }
	    TclEmitPush(objIndex, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_BS:
	    length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
		    buffer);
	    if (length > 0) {
		objIndex = TclRegisterNewLiteral(envPtr, buffer, length);

	    } else {
		objIndex = TclRegisterNewLiteral(envPtr, "", 0);
	    }
	    TclEmitPush(objIndex, envPtr);
	    tokenPtr += 1;
	    break;
	    
        case TCL_TOKEN_COMMAND:
	    code = TclCompileScript(interp, tokenPtr->start+1,
420
421
422
423
424
425
426
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
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_OPERATOR:
	    /*
	     * Look up the operator. Temporarily overwrite the character
	     * just after the end of the operator with a 0 byte. If the
	     * operator isn't found, treat it as a math function.
	     */

	    /*
	     * TODO: Note that the string is modified in place.  This is unsafe
	     * and will break if any of the routines called while the string is
	     * modified have side effects that depend on the original string
	     * being unmodified (e.g. adding an entry to the literal table).
	     */

	    operator = tokenPtr->start;
	    savedChar = operator[tokenPtr->size];
	    operator[tokenPtr->size] = 0;
	    hPtr = Tcl_FindHashEntry(&opHashTable, operator);
	    if (hPtr == NULL) {
		code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
			envPtr, &endPtr);
		operator[tokenPtr->size] = (char) savedChar;
		if (code != TCL_OK) {
		    goto done;
		}
		tokenPtr = endPtr;
		break;
	    }
	    operator[tokenPtr->size] = (char) savedChar;
	    opIndex = (int) Tcl_GetHashValue(hPtr);
	    opDescPtr = &(operatorTable[opIndex]);

	    /*
	     * If the operator is "normal", compile it using information
	     * from the operator table.
	     */







|
<
|

|
<
<
<
<
<
<
|
|
<
<




|






|







419
420
421
422
423
424
425
426

427
428
429






430
431


432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
		goto done;
	    }
	    tokenPtr += (tokenPtr->numComponents + 1);
	    break;
	    
        case TCL_TOKEN_OPERATOR:
	    /*
	     * Look up the operator.  If the operator isn't found, treat it

	     * as a math function.
	     */
	    Tcl_DStringInit(&opBuf);






	    operator = Tcl_DStringAppend(&opBuf, 
		    tokenPtr->start, tokenPtr->size);


	    hPtr = Tcl_FindHashEntry(&opHashTable, operator);
	    if (hPtr == NULL) {
		code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
			envPtr, &endPtr);
		Tcl_DStringFree(&opBuf);
		if (code != TCL_OK) {
		    goto done;
		}
		tokenPtr = endPtr;
		break;
	    }
	    Tcl_DStringFree(&opBuf);
	    opIndex = (int) Tcl_GetHashValue(hPtr);
	    opDescPtr = &(operatorTable[opIndex]);

	    /*
	     * If the operator is "normal", compile it using information
	     * from the operator table.
	     */
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645

    /*
     * Convert the first operand to the result that Tcl requires:
     * "0" or "1". Eventually we'll use a new instruction for this.
     */
    
    TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
    TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr);
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
    dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
        badDist:
	panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr);
    dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
	goto badDist;
    }

    /*
     * Emit the "short circuit" jump around the rest of the expression.







|







|







613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635

    /*
     * Convert the first operand to the result that Tcl requires:
     * "0" or "1". Eventually we'll use a new instruction for this.
     */
    
    TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
    TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
    dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
        badDist:
	panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
    dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
    if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
	goto badDist;
    }

    /*
     * Emit the "short circuit" jump around the rest of the expression.
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
 *----------------------------------------------------------------------
 */

static int
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the math function call. */
    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. */
{







|







822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
 *----------------------------------------------------------------------
 */

static int
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
    Tcl_Token *exprTokenPtr;	/* Points to TCL_TOKEN_SUB_EXPR token
				 * containing the math function call. */
    CONST char *funcName;	/* Name of the math function. */
    ExprInfo *infoPtr;		/* Describes the compilation state for the
				 * expression being compiled. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
    Tcl_Token **endPtrPtr;	/* If successful, a pointer to the token
				 * just after the last token in the
				 * subexpression is stored here. */
{
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
    mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);

    /*
     * If not a builtin function, push an object with the function's name.
     */

    if (mathFuncPtr->builtinFuncIndex < 0) {
	TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0),
	        envPtr);
    }

    /*
     * Compile any arguments for the function.
     */

    tokenPtr = exprTokenPtr+2;







|
<







856
857
858
859
860
861
862
863

864
865
866
867
868
869
870
    mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);

    /*
     * If not a builtin function, push an object with the function's name.
     */

    if (mathFuncPtr->builtinFuncIndex < 0) {
	TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);

    }

    /*
     * Compile any arguments for the function.
     */

    tokenPtr = exprTokenPtr+2;
964
965
966
967
968
969
970

971
972
973
				 * expression being compiled. */
{
    int numBytes = (infoPtr->lastChar - infoPtr->expr);
    char buffer[100];

    sprintf(buffer, "syntax error in expression \"%.*s\"",
	    ((numBytes > 60)? 60 : numBytes), infoPtr->expr);

    Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
	    buffer, (char *) NULL);
}







>



953
954
955
956
957
958
959
960
961
962
963
				 * expression being compiled. */
{
    int numBytes = (infoPtr->lastChar - infoPtr->expr);
    char buffer[100];

    sprintf(buffer, "syntax error in expression \"%.*s\"",
	    ((numBytes > 60)? 60 : numBytes), infoPtr->expr);
    Tcl_ResetResult(infoPtr->interp);
    Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
	    buffer, (char *) NULL);
}
Changes to generic/tclCompile.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts
 *	of commands (like quoted strings or nested sub-commands) into a
 *	sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.25.4.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclCompile.c --
 *
 *	This file contains procedures that compile Tcl commands or parts
 *	of commands (like quoted strings or nested sub-commands) into a
 *	sequence of instructions ("bytecodes"). 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.c,v 1.25.4.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 * and next to topmost stack elements.
 *
 * Note that the load, store, and incr instructions do not distinguish local
 * from global variables; the bytecode interpreter at runtime uses the
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc instructionTable[] = {
   /* Name	      Bytes stackEffect #Opnds Operand types	Stack top, next	  */
    {"done",		  1,   -1,        0,   {OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,   {OPERAND_UINT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,   {OPERAND_UINT4}},
	/* Push object at ByteCode objArray[op4] */







|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 * and next to topmost stack elements.
 *
 * Note that the load, store, and incr instructions do not distinguish local
 * from global variables; the bytecode interpreter at runtime uses the
 * existence of a procedure call frame to distinguish these.
 */

InstructionDesc tclInstructionTable[] = {
   /* Name	      Bytes stackEffect #Opnds Operand types	Stack top, next	  */
    {"done",		  1,   -1,        0,   {OPERAND_NONE}},
	/* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",		  2,   +1,         1,   {OPERAND_UINT1}},
	/* Push object at ByteCode objArray[op1] */
    {"push4",		  5,   +1,         1,   {OPERAND_UINT4}},
	/* Push object at ByteCode objArray[op4] */
288
289
290
291
292
293
294

295
296
297
298
299
300
301
302
    			    CompileEnv *envPtr, int cmdNumber,
			    int srcOffset, int codeOffset));
static void		FreeByteCodeInternalRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr));
static int		GetCmdLocEncodingSize _ANSI_ARGS_((
			    CompileEnv *envPtr));
static void		LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,

        		    char *script, char *command, int length));
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats _ANSI_ARGS_((
			    ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));








>
|







288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
    			    CompileEnv *envPtr, int cmdNumber,
			    int srcOffset, int codeOffset));
static void		FreeByteCodeInternalRep _ANSI_ARGS_((
    			    Tcl_Obj *objPtr));
static int		GetCmdLocEncodingSize _ANSI_ARGS_((
			    CompileEnv *envPtr));
static void		LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
        		    CONST char *script, CONST char *command,
			    int length));
#ifdef TCL_COMPILE_STATS
static void		RecordByteCodeStats _ANSI_ARGS_((
			    ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int		SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));

794
795
796
797
798
799
800
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
 *
 *----------------------------------------------------------------------
 */

int
TclCompileScript(interp, script, numBytes, nested, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int nested;			/* Non-zero means this is a nested command:
				 * close bracket ']' should be considered a
				 * command terminator. If zero, close
				 * bracket has no special meaning. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Parse parse;
    int lastTopLevelCmdIndex = -1;
    				/* Index of most recent toplevel command in
 				 * the command location table. Initialized
				 * to avoid compiler warning. */
    int startCodeOffset = -1;	/* Offset of first byte of current command's
                                 * code. Init. to avoid compiler warning. */
    unsigned char *entryCodeNext = envPtr->codeNext;
    char *p, *next;
    Namespace *cmdNsPtr;
    Command *cmdPtr;
    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
    int commandLength, objIndex, code;
    char prev;
    Tcl_DString ds;







|


















|







795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
 *
 *----------------------------------------------------------------------
 */

int
TclCompileScript(interp, script, numBytes, nested, envPtr)
    Tcl_Interp *interp;		/* Used for error and status reporting. */
    CONST char *script;		/* The source script to compile. */
    int numBytes;		/* Number of bytes in script. If < 0, the
				 * script consists of all bytes up to the
				 * first null character. */
    int nested;			/* Non-zero means this is a nested command:
				 * close bracket ']' should be considered a
				 * command terminator. If zero, close
				 * bracket has no special meaning. */
    CompileEnv *envPtr;		/* Holds resulting instructions. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Parse parse;
    int lastTopLevelCmdIndex = -1;
    				/* Index of most recent toplevel command in
 				 * the command location table. Initialized
				 * to avoid compiler warning. */
    int startCodeOffset = -1;	/* Offset of first byte of current command's
                                 * code. Init. to avoid compiler warning. */
    unsigned char *entryCodeNext = envPtr->codeNext;
    CONST char *p, *next;
    Namespace *cmdNsPtr;
    Command *cmdPtr;
    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
    int commandLength, objIndex, code;
    char prev;
    Tcl_DString ds;
942
943
944
945
946
947
948

949
950
951
952
953
954
955

			cmdPtr = (Command *) Tcl_FindCommand(interp,
				Tcl_DStringValue(&ds),
			        (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);

			if ((cmdPtr != NULL)
			        && (cmdPtr->compileProc != NULL)

			        && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
			    code = (*(cmdPtr->compileProc))(interp, &parse,
			            envPtr);
			    if (code == TCL_OK) {
				goto finishCommand;
			    } else if (code == TCL_OUT_LINE_COMPILE) {
				/* do nothing */







>







943
944
945
946
947
948
949
950
951
952
953
954
955
956
957

			cmdPtr = (Command *) Tcl_FindCommand(interp,
				Tcl_DStringValue(&ds),
			        (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);

			if ((cmdPtr != NULL)
			        && (cmdPtr->compileProc != NULL)
			        && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
			        && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
			    code = (*(cmdPtr->compileProc))(interp, &parse,
			            envPtr);
			    if (code == TCL_OK) {
				goto finishCommand;
			    } else if (code == TCL_OUT_LINE_COMPILE) {
				/* do nothing */
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992

			/*
			 * No compile procedure so push the word. If the
			 * command was found, push a CmdName object to
			 * reduce runtime lookups.
			 */

			objIndex = TclRegisterLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size,
				/*onHeap*/ 0);
			if (cmdPtr != NULL) {
			    TclSetCmdNameObj(interp,
			           envPtr->literalArrayPtr[objIndex].objPtr,
				   cmdPtr);
			}
		    } else {
			objIndex = TclRegisterLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size,
				/*onHeap*/ 0);
		    }
		    TclEmitPush(objIndex, envPtr);
		} else {
		    /*
		     * The word is not a simple string of characters.
		     */
		    







|
|
<






|
|
<







969
970
971
972
973
974
975
976
977

978
979
980
981
982
983
984
985

986
987
988
989
990
991
992

			/*
			 * No compile procedure so push the word. If the
			 * command was found, push a CmdName object to
			 * reduce runtime lookups.
			 */

			objIndex = TclRegisterNewLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size);

			if (cmdPtr != NULL) {
			    TclSetCmdNameObj(interp,
			           envPtr->literalArrayPtr[objIndex].objPtr,
				   cmdPtr);
			}
		    } else {
			objIndex = TclRegisterNewLiteral(envPtr,
				tokenPtr[1].start, tokenPtr[1].size);

		    }
		    TclEmitPush(objIndex, envPtr);
		} else {
		    /*
		     * The word is not a simple string of characters.
		     */
		    
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    char *name, *p;
    int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;
    int length, i, code;
    unsigned char *entryCodeNext = envPtr->codeNext;

    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;
    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {







|
|







1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
    int count;			/* Number of tokens to consider at tokenPtr.
				 * Must be at least 1. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_DString textBuffer;	/* Holds concatenated chars from adjacent
				 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
    char buffer[TCL_UTF_MAX];
    CONST char *name, *p;
    int numObjsToConcat, nameBytes, localVarName, localVar;
    int length, i, code;
    unsigned char *entryCodeNext = envPtr->codeNext;

    Tcl_DStringInit(&textBuffer);
    numObjsToConcat = 0;
    for ( ;  count > 0;  count--, tokenPtr++) {
	switch (tokenPtr->type) {
1183
1184
1185
1186
1187
1188
1189

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
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
		}
		
		/*

		 * Check if the name contains any namespace qualifiers.



		 */
		
		name = tokenPtr[1].start;
		nameBytes = tokenPtr[1].size;


		hasNsQualifiers = 0;
		for (i = 0, p = name;  i < nameBytes;  i++, p++) {
		    if ((*p == ':') && (i < (nameBytes-1))
			    && (*(p+1) == ':')) {





			hasNsQualifiers = 1;
			break;

		    }
		}

		/*
		 * Either push the variable's name, or find its index in
		 * the array of local variables in a procedure frame.
		 */

		if ((envPtr->procPtr == NULL) || hasNsQualifiers) {
		    localVar = -1;
		    TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,
		            /*onHeap*/ 0), envPtr);
		} else {
		    localVar = TclFindCompiledLocal(name, nameBytes, 
			    /*create*/ 0, /*flags*/ 0, envPtr->procPtr);

		    if (localVar < 0) {
			TclEmitPush(TclRegisterLiteral(envPtr, name,
			        nameBytes, /*onHeap*/ 0), envPtr); 
		    }
		}

		/*
		 * Emit instructions to load the variable.
		 */
		
		if (tokenPtr->numComponents == 1) {







>
|
>
>
>




>
>
|
|
|
|
>
>
>
>
>
|
|
>





|


<
|
<
<
|

|
>
|
|
|
<







1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220

1221


1222
1223
1224
1225
1226
1227
1228

1229
1230
1231
1232
1233
1234
1235
			    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
		    TclEmitPush(literal, envPtr);
		    numObjsToConcat++;
		    Tcl_DStringFree(&textBuffer);
		}
		
		/*
		 * Determine how the variable name should be handled: if it contains 
		 * any namespace qualifiers it is not a local variable (localVarName=-1);
		 * if it looks like an array element and the token has a single component, 
		 * it should not be created here [Bug 569438] (localVarName=0); otherwise, 
		 * the local variable can safely be created (localVarName=1).
		 */
		
		name = tokenPtr[1].start;
		nameBytes = tokenPtr[1].size;
		localVarName = -1;
		if (envPtr->procPtr != NULL) {
		    localVarName = 1;
		    for (i = 0, p = name;  i < nameBytes;  i++, p++) {
			if ((*p == ':') && (i < (nameBytes-1))
			        && (*(p+1) == ':')) {
			    localVarName = -1;
			    break;
			} else if ((*p == '(')
			        && (tokenPtr->numComponents == 1) 
				&& (*(name + nameBytes - 1) == ')')) {
			    localVarName = 0;
			    break;
			}
		    }
		}

		/*
		 * Either push the variable's name, or find its index in
		 * the array of local variables in a procedure frame. 
		 */


		localVar = -1;


		if (localVarName != -1) {
		    localVar = TclFindCompiledLocal(name, nameBytes, 
			        localVarName, /*flags*/ 0, envPtr->procPtr);
		}
		if (localVar < 0) {
		    TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
			    envPtr); 

		}

		/*
		 * Emit instructions to load the variable.
		 */
		
		if (tokenPtr->numComponents == 1) {
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
    int numWords;		/* Number of word tokens starting at
				 * tokenPtr. Must be at least 1. Each word
				 * token contains one or more subtokens. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_Token *wordPtr;
    int range, numBytes, i, code;
    char *script;

    range = -1;
    code = TCL_OK;

    /*
     * If the expression is a single word that doesn't require
     * substitutions, just compile it's string into inline instructions.







|







1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
    int numWords;		/* Number of word tokens starting at
				 * tokenPtr. Must be at least 1. Each word
				 * token contains one or more subtokens. */
    CompileEnv *envPtr;		/* Holds the resulting instructions. */
{
    Tcl_Token *wordPtr;
    int range, numBytes, i, code;
    CONST char *script;

    range = -1;
    code = TCL_OK;

    /*
     * If the expression is a single word that doesn't require
     * substitutions, just compile it's string into inline instructions.
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
 *----------------------------------------------------------------------
 */

static void
LogCompilationInfo(interp, script, command, length)
    Tcl_Interp *interp;		/* Interpreter in which to log the
				 * information. */
    char *script;		/* First character in script containing
				 * command (must be <= command). */
    char *command;		/* First character in command that
				 * generated the error. */
    int length;			/* Number of bytes in command (-1 means
				 * use all bytes up to first null byte). */
{
    char buffer[200];
    register char *p;
    char *ellipsis = "";
    Interp *iPtr = (Interp *) interp;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this
	 * command; we shouldn't add anything more.







|

|





|







1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
 *----------------------------------------------------------------------
 */

static void
LogCompilationInfo(interp, script, command, length)
    Tcl_Interp *interp;		/* Interpreter in which to log the
				 * information. */
    CONST char *script;		/* First character in script containing
				 * command (must be <= command). */
    CONST char *command;	/* First character in command that
				 * generated the error. */
    int length;			/* Number of bytes in command (-1 means
				 * use all bytes up to first null byte). */
{
    char buffer[200];
    register CONST char *p;
    char *ellipsis = "";
    Interp *iPtr = (Interp *) interp;

    if (iPtr->flags & ERR_ALREADY_LOGGED) {
	/*
	 * Someone else has already logged error information for this
	 * command; we shouldn't add anything more.
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
	} else {
	    procPtr->lastLocalPtr->nextPtr = localPtr;
	    procPtr->lastLocalPtr = localPtr;
	}
	localPtr->nextPtr = NULL;
	localPtr->nameLength = nameBytes;
	localPtr->frameIndex = localVar;
	localPtr->flags = flags;
	if (name == NULL) {
	    localPtr->flags |= VAR_TEMPORARY;
	}
	localPtr->defValuePtr = NULL;
	localPtr->resolveInfo = NULL;

	if (name != NULL) {







|







1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
	} else {
	    procPtr->lastLocalPtr->nextPtr = localPtr;
	    procPtr->lastLocalPtr = localPtr;
	}
	localPtr->nextPtr = NULL;
	localPtr->nameLength = nameBytes;
	localPtr->frameIndex = localVar;
	localPtr->flags = flags | VAR_UNDEFINED;
	if (name == NULL) {
	    localPtr->flags |= VAR_TEMPORARY;
	}
	localPtr->defValuePtr = NULL;
	localPtr->resolveInfo = NULL;

	if (name != NULL) {
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
	    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 | VAR_UNDEFINED);
        }
	varPtr++;
    }
}

/*
 *----------------------------------------------------------------------







|







1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
	    varPtr->value.objPtr = NULL;
	    varPtr->name = localPtr->name; /* will be just '\0' if temp var */
	    varPtr->nsPtr = NULL;
	    varPtr->hPtr = NULL;
	    varPtr->refCount = 0;
	    varPtr->tracePtr = NULL;
	    varPtr->searchPtr = NULL;
	    varPtr->flags = localPtr->flags;
        }
	varPtr++;
    }
}

/*
 *----------------------------------------------------------------------
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
 *
 *  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 (&instructionTable[0]).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void * /* == InstructionDesc* == */
TclGetInstructionTable()
{
    return &instructionTable[0];
}

/*
 *--------------------------------------------------------------
 *
 * TclRegisterAuxDataType --
 *







|










|







2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
 *
 *  Returns a pointer to the table describing Tcl bytecode instructions.
 *  This procedure is defined so that clients can access the pointer from
 *  outside the TCL DLLs.
 *
 * Results:
 *	Returns a pointer to the global instruction table, same as the
 *	expression (&tclInstructionTable[0]).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void * /* == InstructionDesc* == */
TclGetInstructionTable()
{
    return &tclInstructionTable[0];
}

/*
 *--------------------------------------------------------------
 *
 * TclRegisterAuxDataType --
 *
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
int
TclPrintInstruction(codePtr, pc)
    ByteCode* codePtr;		/* Bytecode containing the instruction. */
    unsigned char *pc;		/* Points to first byte of instruction. */
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register InstructionDesc *instDesc = &instructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned int pcOffset = (pc - codeStart);
    int opnd, i, j;
    
    fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
	switch (instDesc->opTypes[i]) {







|







3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
int
TclPrintInstruction(codePtr, pc)
    ByteCode* codePtr;		/* Bytecode containing the instruction. */
    unsigned char *pc;		/* Points to first byte of instruction. */
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register InstructionDesc *instDesc = &tclInstructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned int pcOffset = (pc - codeStart);
    int opnd, i, j;
    
    fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
	switch (instDesc->opTypes[i]) {
Changes to generic/tclCompile.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclCompile.h --
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.h,v 1.16.4.2 2002/06/10 05:33:10 wolfsuit Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#ifndef _TCLINT
#include "tclInt.h"










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclCompile.h --
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompile.h,v 1.16.4.3 2002/08/20 20:25:25 das Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#ifndef _TCLINT
#include "tclInt.h"
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
/*
 *------------------------------------------------------------------------
 * Variables related to compilation. These are used in tclCompile.c,
 * tclExecute.c, tclBasic.c, and their clients.
 *------------------------------------------------------------------------
 */

/*
 * Variable that denotes the command name Tcl object type. Objects of this
 * type cache the Command pointer that results from looking up command names
 * in the command hashtable.
 */

extern Tcl_ObjType	tclCmdNameType;

#ifdef TCL_COMPILE_DEBUG
/*
 * Variable that controls whether compilation tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled







<
<
<
<
<
<
<
<







26
27
28
29
30
31
32








33
34
35
36
37
38
39
/*
 *------------------------------------------------------------------------
 * Variables related to compilation. These are used in tclCompile.c,
 * tclExecute.c, tclBasic.c, and their clients.
 *------------------------------------------------------------------------
 */









#ifdef TCL_COMPILE_DEBUG
/*
 * Variable that controls whether compilation tracing is enabled and, if so,
 * what level of tracing is desired:
 *    0: no compilation tracing
 *    1: summarize compilation of top level cmds and proc bodies
 *    2: display all instructions of each ByteCode compiled
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
#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, instructionTable, 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







|
|
|
|
|







380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
#ifdef TCL_COMPILE_STATS
    Tcl_Time createTime;	/* Absolute time when the ByteCode was
				 * created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;

/*
 * Opcodes for the Tcl bytecode instructions. These must correspond to
 * the entries in the table of instruction descriptions,
 * tclInstructionTable, in tclCompile.c. Also, the order and number of
 * the expression opcodes (e.g., INST_LOR) must match the entries in
 * the array operatorStrings in tclExecute.c.
 */

/* Opcodes 0 to 9 */
#define INST_DONE			0
#define INST_PUSH1			1
#define INST_PUSH4			2
#define INST_POP			3
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
				 * is (1-opnd1).
				 */
    int numOperands;		/* Number of operands. */
    InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
				/* The type of each operand. */
} InstructionDesc;

extern InstructionDesc instructionTable[];

/*
 * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte. Each value denotes a builtin Tcl math function. These
 * values must correspond to the entries in the builtinFuncTable array
 * below and to the values stored in the tclInt.h MathFunc structure's
 * builtinFuncIndex field.
 */

#define BUILTIN_FUNC_ACOS		0
#define BUILTIN_FUNC_ASIN		1
#define BUILTIN_FUNC_ATAN		2







|




|







554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
				 * is (1-opnd1).
				 */
    int numOperands;		/* Number of operands. */
    InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
				/* The type of each operand. */
} InstructionDesc;

extern InstructionDesc tclInstructionTable[];

/*
 * Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte. Each value denotes a builtin Tcl math function. These
 * values must correspond to the entries in the tclBuiltinFuncTable array
 * below and to the values stored in the tclInt.h MathFunc structure's
 * builtinFuncIndex field.
 */

#define BUILTIN_FUNC_ACOS		0
#define BUILTIN_FUNC_ASIN		1
#define BUILTIN_FUNC_ATAN		2
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
    Tcl_ValueType argTypes[MAX_MATH_ARGS];
				/* Acceptable types for each argument. */
    CallBuiltinFuncProc *proc;	/* Procedure implementing this function. */
    ClientData clientData;	/* Additional argument to pass to the
				 * function when invoking it. */
} BuiltinFunc;

extern BuiltinFunc builtinFuncTable[];

/*
 * 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







|







612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
    Tcl_ValueType argTypes[MAX_MATH_ARGS];
				/* Acceptable types for each argument. */
    CallBuiltinFuncProc *proc;	/* Procedure implementing this function. */
    ClientData clientData;	/* Additional argument to pass to the
				 * function when invoking it. */
} BuiltinFunc;

extern BuiltinFunc tclBuiltinFuncTable[];

/*
 * Compilation of some Tcl constructs such as if commands and the logical or
 * (||) and logical and (&&) operators in expressions requires the
 * generation of forward jumps. Since the PC target of these jumps isn't
 * known when the jumps are emitted, we record the offset of each jump in an
 * array of JumpFixup structures. There is one array for each sequence of
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
/*
 *----------------------------------------------------------------
 * Procedures exported by tclBasic.c to be used within the engine.
 *----------------------------------------------------------------
 */

EXTERN int		TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], char *command, int length,
			    int flags));
EXTERN int              TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));


/*
 *----------------------------------------------------------------
 * Procedures exported by the engine to be used by tclBasic.c







|







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
/*
 *----------------------------------------------------------------
 * Procedures exported by tclBasic.c to be used within the engine.
 *----------------------------------------------------------------
 */

EXTERN int		TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[], CONST char *command, int length,
			    int flags));
EXTERN int              TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));


/*
 *----------------------------------------------------------------
 * Procedures exported by the engine to be used by tclBasic.c
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
 */

EXTERN void		TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr));
EXTERN int		TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int count,
			    CompileEnv *envPtr));
EXTERN int		TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp,
			    char *script, int numBytes,
			    CompileEnv *envPtr));
EXTERN int		TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int numWords,
			    CompileEnv *envPtr));
EXTERN int		TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
			    char *script, int numBytes, int nested,
			    CompileEnv *envPtr));
EXTERN int		TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int count,
			    CompileEnv *envPtr));
EXTERN int		TclCreateAuxData _ANSI_ARGS_((ClientData clientData,
			    AuxDataType *typePtr, CompileEnv *envPtr));
EXTERN int		TclCreateExceptRange _ANSI_ARGS_((







|





|







738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
 */

EXTERN void		TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr));
EXTERN int		TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int count,
			    CompileEnv *envPtr));
EXTERN int		TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *script, int numBytes,
			    CompileEnv *envPtr));
EXTERN int		TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int numWords,
			    CompileEnv *envPtr));
EXTERN int		TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *script, int numBytes, int nested,
			    CompileEnv *envPtr));
EXTERN int		TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Token *tokenPtr, int count,
			    CompileEnv *envPtr));
EXTERN int		TclCreateAuxData _ANSI_ARGS_((ClientData clientData,
			    AuxDataType *typePtr, CompileEnv *envPtr));
EXTERN int		TclCreateExceptRange _ANSI_ARGS_((
831
832
833
834
835
836
837









838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
/*
 *----------------------------------------------------------------
 * Macros used by Tcl bytecode compilation and execution modules
 * inside the Tcl core but not used outside.
 *----------------------------------------------------------------
 */










/*
 * Macro used to update the stack requirements.
 * It is called by the macros TclEmitOpCode, TclEmitInst1 and
 * TclEmitInst4.
 * Remark that the very last instruction of a bytecode always
 * reduces the stack level: INST_DONE or INST_POP, so that the 
 * maxStackdepth is always updated.
 */

#define TclUpdateStackReqs(op, i, envPtr) \
    {\
	int delta = instructionTable[(op)].stackEffect;\
	if (delta) {\
	    if (delta < 0) {\
		if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
		    (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
		}\
		if (delta == INT_MIN) {\
		    delta = 1 - (i);\







>
>
>
>
>
>
>
>
>











|







823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
/*
 *----------------------------------------------------------------
 * Macros used by Tcl bytecode compilation and execution modules
 * inside the Tcl core but not used outside.
 *----------------------------------------------------------------
 */

/*
 * Form of TclRegisterLiteral with onHeap == 0.
 * In that case, it is safe to cast away CONSTness, and it
 * is cleanest to do that here, all in one place.
 */

#define TclRegisterNewLiteral(envPtr, bytes, length) \
	TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0)

/*
 * Macro used to update the stack requirements.
 * It is called by the macros TclEmitOpCode, TclEmitInst1 and
 * TclEmitInst4.
 * Remark that the very last instruction of a bytecode always
 * reduces the stack level: INST_DONE or INST_POP, so that the 
 * maxStackdepth is always updated.
 */

#define TclUpdateStackReqs(op, i, envPtr) \
    {\
	int delta = tclInstructionTable[(op)].stackEffect;\
	if (delta) {\
	    if (delta < 0) {\
		if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
		    (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
		}\
		if (delta == INT_MIN) {\
		    delta = 1 - (i);\
928
929
930
931
932
933
934


935
936
937
938

939
940
941
942
943
944
945
 * array. These support, respectively, a maximum of 256 (2**8) and 2**32
 * objects in a CompileEnv. The ANSI C "prototype" for this macro is:
 *
 * EXTERN void	TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
 */

#define TclEmitPush(objIndex, envPtr) \


    if ((objIndex) <= 255) { \
	TclEmitInstInt1(INST_PUSH1, (objIndex), (envPtr)); \
    } else { \
	TclEmitInstInt4(INST_PUSH4, (objIndex), (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:
 *







>
>
|
|
|
|
>







929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
 * array. These support, respectively, a maximum of 256 (2**8) and 2**32
 * objects in a CompileEnv. The ANSI C "prototype" for this macro is:
 *
 * EXTERN void	TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
 */

#define TclEmitPush(objIndex, envPtr) \
    {\
        register int objIndexCopy = (objIndex);\
        if (objIndexCopy <= 255) { \
	    TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
        } else { \
	    TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
	}\
    }

/*
 * Macros to update a (signed or unsigned) integer starting at a pointer.
 * The two variants depend on the number of bytes. The ANSI C "prototypes"
 * for these macros are:
 *
Changes to generic/tclDecls.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.63.2.4 2002/06/10 05:33:10 wolfsuit Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclDecls.h --
 *
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.63.2.5 2002/08/20 20:25:25 das Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl
27
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
 */

/* 0 */
EXTERN int		Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp, 
				CONST char* name, CONST char* version, 
				ClientData clientData));
/* 1 */
EXTERN CONST char *	Tcl_PkgRequireEx _ANSI_ARGS_((Tcl_Interp * interp, 

				CONST char * name, CONST char * version, 
				int exact, ClientData * clientDataPtr));
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
/* 4 */
EXTERN void		Tcl_Free _ANSI_ARGS_((char * ptr));
/* 5 */
EXTERN char *		Tcl_Realloc _ANSI_ARGS_((char * ptr, 
				unsigned int size));
/* 6 */
EXTERN char *		Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, 
				CONST char * file, int line));
/* 7 */
EXTERN int		Tcl_DbCkfree _ANSI_ARGS_((char * ptr, 
				CONST char * file, int line));
/* 8 */
EXTERN char *		Tcl_DbCkrealloc _ANSI_ARGS_((char * ptr, 
				unsigned int size, CONST char * file, 
				int line));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 9 */
EXTERN void		Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask, 
				Tcl_FileProc * proc, ClientData clientData));
#endif /* UNIX */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 10 */
EXTERN void		Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
#endif /* UNIX */
/* 11 */
EXTERN void		Tcl_SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
/* 12 */
EXTERN void		Tcl_Sleep _ANSI_ARGS_((int ms));







|
>
|
|



















|




|







27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 */

/* 0 */
EXTERN int		Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp, 
				CONST char* name, CONST char* version, 
				ClientData clientData));
/* 1 */
EXTERN CONST84_RETURN char * Tcl_PkgRequireEx _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
/* 2 */
EXTERN void		Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
/* 3 */
EXTERN char *		Tcl_Alloc _ANSI_ARGS_((unsigned int size));
/* 4 */
EXTERN void		Tcl_Free _ANSI_ARGS_((char * ptr));
/* 5 */
EXTERN char *		Tcl_Realloc _ANSI_ARGS_((char * ptr, 
				unsigned int size));
/* 6 */
EXTERN char *		Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, 
				CONST char * file, int line));
/* 7 */
EXTERN int		Tcl_DbCkfree _ANSI_ARGS_((char * ptr, 
				CONST char * file, int line));
/* 8 */
EXTERN char *		Tcl_DbCkrealloc _ANSI_ARGS_((char * ptr, 
				unsigned int size, CONST char * file, 
				int line));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 9 */
EXTERN void		Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask, 
				Tcl_FileProc * proc, ClientData clientData));
#endif /* UNIX */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 10 */
EXTERN void		Tcl_DeleteFileHandler _ANSI_ARGS_((int fd));
#endif /* UNIX */
/* 11 */
EXTERN void		Tcl_SetTimer _ANSI_ARGS_((Tcl_Time * timePtr));
/* 12 */
EXTERN void		Tcl_Sleep _ANSI_ARGS_((int ms));
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
EXTERN void		Tcl_CancelIdleCall _ANSI_ARGS_((
				Tcl_IdleProc * idleProc, 
				ClientData clientData));
/* 81 */
EXTERN int		Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel chan));
/* 82 */
EXTERN int		Tcl_CommandComplete _ANSI_ARGS_((char * cmd));
/* 83 */
EXTERN char *		Tcl_Concat _ANSI_ARGS_((int argc, 
				CONST84 char * CONST * argv));
/* 84 */
EXTERN int		Tcl_ConvertElement _ANSI_ARGS_((CONST char * src, 
				char * dst, int flags));
/* 85 */
EXTERN int		Tcl_ConvertCountedElement _ANSI_ARGS_((
				CONST char * src, int length, char * dst, 
				int flags));
/* 86 */
EXTERN int		Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp * slave, 
				CONST char * slaveCmd, Tcl_Interp * target, 
				CONST char * targetCmd, int argc, 
				char * CONST * argv));
/* 87 */
EXTERN int		Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp * slave, 
				CONST char * slaveCmd, Tcl_Interp * target, 
				CONST char * targetCmd, int objc, 
				Tcl_Obj *CONST objv[]));
/* 88 */
EXTERN Tcl_Channel	Tcl_CreateChannel _ANSI_ARGS_((







|














|







268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
EXTERN void		Tcl_CancelIdleCall _ANSI_ARGS_((
				Tcl_IdleProc * idleProc, 
				ClientData clientData));
/* 81 */
EXTERN int		Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel chan));
/* 82 */
EXTERN int		Tcl_CommandComplete _ANSI_ARGS_((CONST char * cmd));
/* 83 */
EXTERN char *		Tcl_Concat _ANSI_ARGS_((int argc, 
				CONST84 char * CONST * argv));
/* 84 */
EXTERN int		Tcl_ConvertElement _ANSI_ARGS_((CONST char * src, 
				char * dst, int flags));
/* 85 */
EXTERN int		Tcl_ConvertCountedElement _ANSI_ARGS_((
				CONST char * src, int length, char * dst, 
				int flags));
/* 86 */
EXTERN int		Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp * slave, 
				CONST char * slaveCmd, Tcl_Interp * target, 
				CONST char * targetCmd, int argc, 
				CONST84 char * CONST * argv));
/* 87 */
EXTERN int		Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp * slave, 
				CONST char * slaveCmd, Tcl_Interp * target, 
				CONST char * targetCmd, int objc, 
				Tcl_Obj *CONST objv[]));
/* 88 */
EXTERN Tcl_Channel	Tcl_CreateChannel _ANSI_ARGS_((
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
EXTERN void		Tcl_DeleteHashEntry _ANSI_ARGS_((
				Tcl_HashEntry * entryPtr));
/* 109 */
EXTERN void		Tcl_DeleteHashTable _ANSI_ARGS_((
				Tcl_HashTable * tablePtr));
/* 110 */
EXTERN void		Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp * interp));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 111 */
EXTERN void		Tcl_DetachPids _ANSI_ARGS_((int numPids, 
				Tcl_Pid * pidPtr));
#endif /* UNIX */
#ifdef __WIN32__
/* 111 */
EXTERN void		Tcl_DetachPids _ANSI_ARGS_((int numPids, 







|







373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
EXTERN void		Tcl_DeleteHashEntry _ANSI_ARGS_((
				Tcl_HashEntry * entryPtr));
/* 109 */
EXTERN void		Tcl_DeleteHashTable _ANSI_ARGS_((
				Tcl_HashTable * tablePtr));
/* 110 */
EXTERN void		Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp * interp));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 111 */
EXTERN void		Tcl_DetachPids _ANSI_ARGS_((int numPids, 
				Tcl_Pid * pidPtr));
#endif /* UNIX */
#ifdef __WIN32__
/* 111 */
EXTERN void		Tcl_DetachPids _ANSI_ARGS_((int numPids, 
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
				Tcl_DString * dsPtr, int length));
/* 125 */
EXTERN void		Tcl_DStringStartSublist _ANSI_ARGS_((
				Tcl_DString * dsPtr));
/* 126 */
EXTERN int		Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
/* 127 */
EXTERN CONST char *	Tcl_ErrnoId _ANSI_ARGS_((void));
/* 128 */
EXTERN CONST char *	Tcl_ErrnoMsg _ANSI_ARGS_((int err));
/* 129 */
EXTERN int		Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, 
				char * string));
/* 130 */
EXTERN int		Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * fileName));
/* 131 */
EXTERN int		Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr));
/* 132 */







|

|


|







427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
				Tcl_DString * dsPtr, int length));
/* 125 */
EXTERN void		Tcl_DStringStartSublist _ANSI_ARGS_((
				Tcl_DString * dsPtr));
/* 126 */
EXTERN int		Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
/* 127 */
EXTERN CONST84_RETURN char * Tcl_ErrnoId _ANSI_ARGS_((void));
/* 128 */
EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
/* 129 */
EXTERN int		Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string));
/* 130 */
EXTERN int		Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * fileName));
/* 131 */
EXTERN int		Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr));
/* 132 */
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
/* 147 */
EXTERN void		Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp));
/* 148 */
EXTERN int		Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * slaveCmd, 
				Tcl_Interp ** targetInterpPtr, 
				CONST84 char ** targetCmdPtr, int * argcPtr, 
				char *** argvPtr));
/* 149 */
EXTERN int		Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * slaveCmd, 
				Tcl_Interp ** targetInterpPtr, 
				CONST84 char ** targetCmdPtr, int * objcPtr, 
				Tcl_Obj *** objv));
/* 150 */







|







490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
/* 147 */
EXTERN void		Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp));
/* 148 */
EXTERN int		Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * slaveCmd, 
				Tcl_Interp ** targetInterpPtr, 
				CONST84 char ** targetCmdPtr, int * argcPtr, 
				CONST84 char *** argvPtr));
/* 149 */
EXTERN int		Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * slaveCmd, 
				Tcl_Interp ** targetInterpPtr, 
				CONST84 char ** targetCmdPtr, int * objcPtr, 
				Tcl_Obj *** objv));
/* 150 */
515
516
517
518
519
520
521
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
				int direction, ClientData * handlePtr));
/* 154 */
EXTERN ClientData	Tcl_GetChannelInstanceData _ANSI_ARGS_((
				Tcl_Channel chan));
/* 155 */
EXTERN int		Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan));
/* 156 */
EXTERN CONST char *	Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan));

/* 157 */
EXTERN int		Tcl_GetChannelOption _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Channel chan, 
				CONST char * optionName, Tcl_DString * dsPtr));
/* 158 */
EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
/* 159 */
EXTERN int		Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * cmdName, Tcl_CmdInfo * infoPtr));
/* 160 */
EXTERN CONST char *	Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Command command));
/* 161 */
EXTERN int		Tcl_GetErrno _ANSI_ARGS_((void));
/* 162 */
EXTERN CONST char *	Tcl_GetHostName _ANSI_ARGS_((void));
/* 163 */
EXTERN int		Tcl_GetInterpPath _ANSI_ARGS_((
				Tcl_Interp * askInterp, 
				Tcl_Interp * slaveInterp));
/* 164 */
EXTERN Tcl_Interp *	Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp * interp));
/* 165 */
EXTERN CONST char *	Tcl_GetNameOfExecutable _ANSI_ARGS_((void));
/* 166 */
EXTERN Tcl_Obj *	Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 167 */
EXTERN int		Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, int forWriting, 
				int checkUsage, ClientData * filePtr));
#endif /* UNIX */
/* 168 */
EXTERN Tcl_PathType	Tcl_GetPathType _ANSI_ARGS_((CONST char * path));







|
>










|
|



|










|







516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
				int direction, ClientData * handlePtr));
/* 154 */
EXTERN ClientData	Tcl_GetChannelInstanceData _ANSI_ARGS_((
				Tcl_Channel chan));
/* 155 */
EXTERN int		Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan));
/* 156 */
EXTERN CONST84_RETURN char * Tcl_GetChannelName _ANSI_ARGS_((
				Tcl_Channel chan));
/* 157 */
EXTERN int		Tcl_GetChannelOption _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Channel chan, 
				CONST char * optionName, Tcl_DString * dsPtr));
/* 158 */
EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
/* 159 */
EXTERN int		Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * cmdName, Tcl_CmdInfo * infoPtr));
/* 160 */
EXTERN CONST84_RETURN char * Tcl_GetCommandName _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Command command));
/* 161 */
EXTERN int		Tcl_GetErrno _ANSI_ARGS_((void));
/* 162 */
EXTERN CONST84_RETURN char * Tcl_GetHostName _ANSI_ARGS_((void));
/* 163 */
EXTERN int		Tcl_GetInterpPath _ANSI_ARGS_((
				Tcl_Interp * askInterp, 
				Tcl_Interp * slaveInterp));
/* 164 */
EXTERN Tcl_Interp *	Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp * interp));
/* 165 */
EXTERN CONST char *	Tcl_GetNameOfExecutable _ANSI_ARGS_((void));
/* 166 */
EXTERN Tcl_Obj *	Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 167 */
EXTERN int		Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, int forWriting, 
				int checkUsage, ClientData * filePtr));
#endif /* UNIX */
/* 168 */
EXTERN Tcl_PathType	Tcl_GetPathType _ANSI_ARGS_((CONST char * path));
564
565
566
567
568
569
570
571

572
573
574
575
576
577

578
579
580
581
582
583
584
585
586
587
EXTERN int		Tcl_GetServiceMode _ANSI_ARGS_((void));
/* 172 */
EXTERN Tcl_Interp *	Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * slaveName));
/* 173 */
EXTERN Tcl_Channel	Tcl_GetStdChannel _ANSI_ARGS_((int type));
/* 174 */
EXTERN CONST char *	Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp * interp));

/* 175 */
EXTERN CONST char *	Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, int flags));
/* 176 */
EXTERN CONST char *	Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags));

/* 177 */
EXTERN int		Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp * interp, 
				char * command));
/* 178 */
EXTERN int		Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr));
/* 179 */
EXTERN int		Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * cmdName, 
				CONST char * hiddenCmdToken));







|
>

|
|

|
|
>


|







566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
EXTERN int		Tcl_GetServiceMode _ANSI_ARGS_((void));
/* 172 */
EXTERN Tcl_Interp *	Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * slaveName));
/* 173 */
EXTERN Tcl_Channel	Tcl_GetStdChannel _ANSI_ARGS_((int type));
/* 174 */
EXTERN CONST84_RETURN char * Tcl_GetStringResult _ANSI_ARGS_((
				Tcl_Interp * interp));
/* 175 */
EXTERN CONST84_RETURN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags));
/* 176 */
EXTERN CONST84_RETURN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags));
/* 177 */
EXTERN int		Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * command));
/* 178 */
EXTERN int		Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr));
/* 179 */
EXTERN int		Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * cmdName, 
				CONST char * hiddenCmdToken));
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
EXTERN int		Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp));
/* 186 */
EXTERN char *		Tcl_JoinPath _ANSI_ARGS_((int argc, 
				CONST84 char * CONST * argv, 
				Tcl_DString * resultPtr));
/* 187 */
EXTERN int		Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, char * addr, int type));
/* Slot 188 is reserved */
/* 189 */
EXTERN Tcl_Channel	Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle, 
				int mode));
/* 190 */
EXTERN int		Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp * interp));
/* 191 */







|







604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
EXTERN int		Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp));
/* 186 */
EXTERN char *		Tcl_JoinPath _ANSI_ARGS_((int argc, 
				CONST84 char * CONST * argv, 
				Tcl_DString * resultPtr));
/* 187 */
EXTERN int		Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, char * addr, int type));
/* Slot 188 is reserved */
/* 189 */
EXTERN Tcl_Channel	Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle, 
				int mode));
/* 190 */
EXTERN int		Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp * interp));
/* 191 */
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
EXTERN Tcl_Obj *	Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				int flags));
/* 196 */
EXTERN Tcl_Obj *	Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				Tcl_Obj * newValuePtr, int flags));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 197 */
EXTERN Tcl_Channel	Tcl_OpenCommandChannel _ANSI_ARGS_((
				Tcl_Interp * interp, int argc, 
				CONST84 char ** argv, int flags));
#endif /* UNIX */
#ifdef __WIN32__
/* 197 */







|







631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
EXTERN Tcl_Obj *	Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				int flags));
/* 196 */
EXTERN Tcl_Obj *	Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				Tcl_Obj * newValuePtr, int flags));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 197 */
EXTERN Tcl_Channel	Tcl_OpenCommandChannel _ANSI_ARGS_((
				Tcl_Interp * interp, int argc, 
				CONST84 char ** argv, int flags));
#endif /* UNIX */
#ifdef __WIN32__
/* 197 */
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
EXTERN void		Tcl_Preserve _ANSI_ARGS_((ClientData data));
/* 202 */
EXTERN void		Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				double value, char * dst));
/* 203 */
EXTERN int		Tcl_PutEnv _ANSI_ARGS_((CONST char * string));
/* 204 */
EXTERN CONST char *	Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
/* 205 */
EXTERN void		Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event * evPtr, 
				Tcl_QueuePosition position));
/* 206 */
EXTERN int		Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, 
				char * bufPtr, int toRead));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 207 */
EXTERN void		Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
#endif /* UNIX */
#ifdef __WIN32__
/* 207 */
EXTERN void		Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
#endif /* __WIN32__ */







|






|







664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
EXTERN void		Tcl_Preserve _ANSI_ARGS_((ClientData data));
/* 202 */
EXTERN void		Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, 
				double value, char * dst));
/* 203 */
EXTERN int		Tcl_PutEnv _ANSI_ARGS_((CONST char * string));
/* 204 */
EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
/* 205 */
EXTERN void		Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event * evPtr, 
				Tcl_QueuePosition position));
/* 206 */
EXTERN int		Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, 
				char * bufPtr, int toRead));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 207 */
EXTERN void		Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
#endif /* UNIX */
#ifdef __WIN32__
/* 207 */
EXTERN void		Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
#endif /* __WIN32__ */
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
/* 235 */
EXTERN void		Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * resultObjPtr));
/* 236 */
EXTERN void		Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, 
				int type));
/* 237 */
EXTERN CONST char *	Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, CONST char * newValue, 
				int flags));
/* 238 */
EXTERN CONST char *	Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, 
				CONST char * newValue, int flags));
/* 239 */
EXTERN CONST char *	Tcl_SignalId _ANSI_ARGS_((int sig));
/* 240 */
EXTERN CONST char *	Tcl_SignalMsg _ANSI_ARGS_((int sig));
/* 241 */
EXTERN void		Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp));
/* 242 */
EXTERN int		Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * listStr, int * argcPtr, 
				CONST84 char *** argvPtr));
/* 243 */







|
|


|
|


|

|







767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
/* 235 */
EXTERN void		Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * resultObjPtr));
/* 236 */
EXTERN void		Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, 
				int type));
/* 237 */
EXTERN CONST84_RETURN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, CONST char * newValue, 
				int flags));
/* 238 */
EXTERN CONST84_RETURN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				CONST char * newValue, int flags));
/* 239 */
EXTERN CONST84_RETURN char * Tcl_SignalId _ANSI_ARGS_((int sig));
/* 240 */
EXTERN CONST84_RETURN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
/* 241 */
EXTERN void		Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp));
/* 242 */
EXTERN int		Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * listStr, int * argcPtr, 
				CONST84 char *** argvPtr));
/* 243 */
795
796
797
798
799
800
801
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
/* 245 */
EXTERN int		Tcl_StringMatch _ANSI_ARGS_((CONST char * str, 
				CONST char * pattern));
/* 246 */
EXTERN int		Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan));
/* 247 */
EXTERN int		Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, int flags, 
				Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 248 */
EXTERN int		Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags, 
				Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 249 */
EXTERN char *		Tcl_TranslateFileName _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name, 
				Tcl_DString * bufferPtr));
/* 250 */
EXTERN int		Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, 
				CONST char * str, int len, int atHead));
/* 251 */
EXTERN void		Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName));
/* 252 */
EXTERN int		Tcl_UnregisterChannel _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Channel chan));
/* 253 */
EXTERN int		Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, int flags));
/* 254 */
EXTERN int		Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags));

/* 255 */
EXTERN void		Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, int flags, 
				Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 256 */
EXTERN void		Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags, 
				Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 257 */
EXTERN void		Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName));
/* 258 */
EXTERN int		Tcl_UpVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * frameName, char * varName, 
				CONST char * localName, int flags));
/* 259 */
EXTERN int		Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * frameName, char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
				ClientData prevClientData));
/* 262 */
EXTERN ClientData	Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags, 
				Tcl_VarTraceProc * procPtr, 
				ClientData prevClientData));
/* 263 */
EXTERN int		Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, 
				CONST char * s, int slen));
/* 264 */
EXTERN void		Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp * interp, 
				int objc, Tcl_Obj *CONST objv[], 







|




|
|










|





|


|
>


|




|
|



|


|



|






|




|
|







799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
/* 245 */
EXTERN int		Tcl_StringMatch _ANSI_ARGS_((CONST char * str, 
				CONST char * pattern));
/* 246 */
EXTERN int		Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan));
/* 247 */
EXTERN int		Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 248 */
EXTERN int		Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags, Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 249 */
EXTERN char *		Tcl_TranslateFileName _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name, 
				Tcl_DString * bufferPtr));
/* 250 */
EXTERN int		Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, 
				CONST char * str, int len, int atHead));
/* 251 */
EXTERN void		Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName));
/* 252 */
EXTERN int		Tcl_UnregisterChannel _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Channel chan));
/* 253 */
EXTERN int		Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags));
/* 254 */
EXTERN int		Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags));
/* 255 */
EXTERN void		Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 256 */
EXTERN void		Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags, Tcl_VarTraceProc * proc, 
				ClientData clientData));
/* 257 */
EXTERN void		Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName));
/* 258 */
EXTERN int		Tcl_UpVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * frameName, CONST char * varName, 
				CONST char * localName, int flags));
/* 259 */
EXTERN int		Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * frameName, CONST char * part1, 
				CONST char * part2, CONST char * localName, 
				int flags));
/* 260 */
EXTERN int		Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 261 */
EXTERN ClientData	Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName, int flags, 
				Tcl_VarTraceProc * procPtr, 
				ClientData prevClientData));
/* 262 */
EXTERN ClientData	Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags, Tcl_VarTraceProc * procPtr, 
				ClientData prevClientData));
/* 263 */
EXTERN int		Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, 
				CONST char * s, int slen));
/* 264 */
EXTERN void		Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp * interp, 
				int objc, Tcl_Obj *CONST objv[], 
876
877
878
879
880
881
882

883
884
885
886
887
888
889
890
891
892

893
894
895
896
897
898
899
900
901
902
903
904
905
906
/* 267 */
EXTERN void		Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp, 
				va_list argList));
/* 268 */
EXTERN void		Tcl_AppendStringsToObjVA _ANSI_ARGS_((
				Tcl_Obj * objPtr, va_list argList));
/* 269 */

EXTERN CONST char *	Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable * tablePtr));
/* 270 */
EXTERN CONST char *	Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * str, char ** termPtr));
/* 271 */
EXTERN CONST char *	Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version, 
				int exact));
/* 272 */
EXTERN CONST char *	Tcl_PkgPresentEx _ANSI_ARGS_((Tcl_Interp * interp, 

				CONST char * name, CONST char * version, 
				int exact, ClientData * clientDataPtr));
/* 273 */
EXTERN int		Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version));
/* 274 */
EXTERN CONST char *	Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version, 
				int exact));
/* 275 */
EXTERN void		Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp * interp, 
				va_list argList));
/* 276 */
EXTERN int		Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp, 







>
|

|
|

|



|
>
|
|




|







881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
/* 267 */
EXTERN void		Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp, 
				va_list argList));
/* 268 */
EXTERN void		Tcl_AppendStringsToObjVA _ANSI_ARGS_((
				Tcl_Obj * objPtr, va_list argList));
/* 269 */
EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_((
				Tcl_HashTable * tablePtr));
/* 270 */
EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, CONST84 char ** termPtr));
/* 271 */
EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version, 
				int exact));
/* 272 */
EXTERN CONST84_RETURN char * Tcl_PkgPresentEx _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name, 
				CONST char * version, int exact, 
				ClientData * clientDataPtr));
/* 273 */
EXTERN int		Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version));
/* 274 */
EXTERN CONST84_RETURN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name, CONST char * version, 
				int exact));
/* 275 */
EXTERN void		Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp * interp, 
				va_list argList));
/* 276 */
EXTERN int		Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp, 
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
EXTERN void		Tcl_DeleteThreadExitHandler _ANSI_ARGS_((
				Tcl_ExitProc * proc, ClientData clientData));
/* 290 */
EXTERN void		Tcl_DiscardResult _ANSI_ARGS_((
				Tcl_SavedResult * statePtr));
/* 291 */
EXTERN int		Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, 
				char * script, int numBytes, int flags));
/* 292 */
EXTERN int		Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp, 
				int objc, Tcl_Obj *CONST objv[], int flags));
/* 293 */
EXTERN int		Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int flags));
/* 294 */







|







949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
EXTERN void		Tcl_DeleteThreadExitHandler _ANSI_ARGS_((
				Tcl_ExitProc * proc, ClientData clientData));
/* 290 */
EXTERN void		Tcl_DiscardResult _ANSI_ARGS_((
				Tcl_SavedResult * statePtr));
/* 291 */
EXTERN int		Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * script, int numBytes, int flags));
/* 292 */
EXTERN int		Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp, 
				int objc, Tcl_Obj *CONST objv[], int flags));
/* 293 */
EXTERN int		Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int flags));
/* 294 */
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997

998
999
1000
1001
1002
1003
1004
EXTERN void		Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
/* 300 */
EXTERN Tcl_ThreadId	Tcl_GetCurrentThread _ANSI_ARGS_((void));
/* 301 */
EXTERN Tcl_Encoding	Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name));
/* 302 */
EXTERN CONST char *	Tcl_GetEncodingName _ANSI_ARGS_((
				Tcl_Encoding encoding));
/* 303 */
EXTERN void		Tcl_GetEncodingNames _ANSI_ARGS_((
				Tcl_Interp * interp));
/* 304 */
EXTERN int		Tcl_GetIndexFromObjStruct _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				CONST VOID * tablePtr, int offset, 
				CONST char * msg, int flags, int * indexPtr));
/* 305 */
EXTERN VOID *		Tcl_GetThreadData _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr, int size));
/* 306 */
EXTERN Tcl_Obj *	Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags));

/* 307 */
EXTERN ClientData	Tcl_InitNotifier _ANSI_ARGS_((void));
/* 308 */
EXTERN void		Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
/* 309 */
EXTERN void		Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
/* 310 */







|














|
>







982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
EXTERN void		Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
/* 300 */
EXTERN Tcl_ThreadId	Tcl_GetCurrentThread _ANSI_ARGS_((void));
/* 301 */
EXTERN Tcl_Encoding	Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * name));
/* 302 */
EXTERN CONST84_RETURN char * Tcl_GetEncodingName _ANSI_ARGS_((
				Tcl_Encoding encoding));
/* 303 */
EXTERN void		Tcl_GetEncodingNames _ANSI_ARGS_((
				Tcl_Interp * interp));
/* 304 */
EXTERN int		Tcl_GetIndexFromObjStruct _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				CONST VOID * tablePtr, int offset, 
				CONST char * msg, int flags, int * indexPtr));
/* 305 */
EXTERN VOID *		Tcl_GetThreadData _ANSI_ARGS_((
				Tcl_ThreadDataKey * keyPtr, int size));
/* 306 */
EXTERN Tcl_Obj *	Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags));
/* 307 */
EXTERN ClientData	Tcl_InitNotifier _ANSI_ARGS_((void));
/* 308 */
EXTERN void		Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
/* 309 */
EXTERN void		Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
/* 310 */
1022
1023
1024
1025
1026
1027
1028
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
EXTERN void		Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_SavedResult * statePtr));
/* 316 */
EXTERN int		Tcl_SetSystemEncoding _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name));
/* 317 */
EXTERN Tcl_Obj *	Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, 
				Tcl_Obj * newValuePtr, int flags));
/* 318 */
EXTERN void		Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
/* 319 */
EXTERN void		Tcl_ThreadQueueEvent _ANSI_ARGS_((
				Tcl_ThreadId threadId, Tcl_Event* evPtr, 
				Tcl_QueuePosition position));
/* 320 */
EXTERN Tcl_UniChar	Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src, 
				int index));
/* 321 */
EXTERN Tcl_UniChar	Tcl_UniCharToLower _ANSI_ARGS_((int ch));
/* 322 */
EXTERN Tcl_UniChar	Tcl_UniCharToTitle _ANSI_ARGS_((int ch));
/* 323 */
EXTERN Tcl_UniChar	Tcl_UniCharToUpper _ANSI_ARGS_((int ch));
/* 324 */
EXTERN int		Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf));
/* 325 */
EXTERN CONST char *	Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, 
				int index));
/* 326 */
EXTERN int		Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, 
				int len));
/* 327 */
EXTERN int		Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, 
				int * readPtr, char * dst));
/* 328 */
EXTERN CONST char *	Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, 
				int ch));
/* 329 */
EXTERN CONST char *	Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, 
				int ch));
/* 330 */
EXTERN CONST char *	Tcl_UtfNext _ANSI_ARGS_((CONST char * src));
/* 331 */
EXTERN CONST char *	Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, 
				CONST char * start));
/* 332 */
EXTERN int		Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Encoding encoding, CONST char * src, 
				int srcLen, int flags, 
				Tcl_EncodingState * statePtr, char * dst, 
				int dstLen, int * srcReadPtr, 







|



















|








|


|


|

|







1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
EXTERN void		Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_SavedResult * statePtr));
/* 316 */
EXTERN int		Tcl_SetSystemEncoding _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name));
/* 317 */
EXTERN Tcl_Obj *	Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				Tcl_Obj * newValuePtr, int flags));
/* 318 */
EXTERN void		Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
/* 319 */
EXTERN void		Tcl_ThreadQueueEvent _ANSI_ARGS_((
				Tcl_ThreadId threadId, Tcl_Event* evPtr, 
				Tcl_QueuePosition position));
/* 320 */
EXTERN Tcl_UniChar	Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src, 
				int index));
/* 321 */
EXTERN Tcl_UniChar	Tcl_UniCharToLower _ANSI_ARGS_((int ch));
/* 322 */
EXTERN Tcl_UniChar	Tcl_UniCharToTitle _ANSI_ARGS_((int ch));
/* 323 */
EXTERN Tcl_UniChar	Tcl_UniCharToUpper _ANSI_ARGS_((int ch));
/* 324 */
EXTERN int		Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf));
/* 325 */
EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, 
				int index));
/* 326 */
EXTERN int		Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, 
				int len));
/* 327 */
EXTERN int		Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, 
				int * readPtr, char * dst));
/* 328 */
EXTERN CONST84_RETURN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, 
				int ch));
/* 329 */
EXTERN CONST84_RETURN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, 
				int ch));
/* 330 */
EXTERN CONST84_RETURN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src));
/* 331 */
EXTERN CONST84_RETURN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, 
				CONST char * start));
/* 332 */
EXTERN int		Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Encoding encoding, CONST char * src, 
				int srcLen, int flags, 
				Tcl_EncodingState * statePtr, char * dst, 
				int dstLen, int * srcReadPtr, 
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
				CONST char * src, int srcLen));
/* 339 */
EXTERN int		Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_Obj * objPtr));
/* 340 */
EXTERN char *		Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 341 */
EXTERN CONST char *	Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
/* 342 */
EXTERN void		Tcl_SetDefaultEncodingDir _ANSI_ARGS_((
				CONST char * path));
/* 343 */
EXTERN void		Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
/* 344 */
EXTERN void		Tcl_ServiceModeHook _ANSI_ARGS_((int mode));







|







1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
				CONST char * src, int srcLen));
/* 339 */
EXTERN int		Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, 
				Tcl_Obj * objPtr));
/* 340 */
EXTERN char *		Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 341 */
EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
/* 342 */
EXTERN void		Tcl_SetDefaultEncodingDir _ANSI_ARGS_((
				CONST char * path));
/* 343 */
EXTERN void		Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
/* 344 */
EXTERN void		Tcl_ServiceModeHook _ANSI_ARGS_((int mode));
1140
1141
1142
1143
1144
1145
1146
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
EXTERN void		Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr));
/* 359 */
EXTERN void		Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * script, CONST char * command, 
				int length));
/* 360 */
EXTERN int		Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, 
				char * string, int numBytes, 
				Tcl_Parse * parsePtr, int append, 
				char ** termPtr));
/* 361 */
EXTERN int		Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				char * string, int numBytes, int nested, 
				Tcl_Parse * parsePtr));
/* 362 */
EXTERN int		Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, 
				char * string, int numBytes, 
				Tcl_Parse * parsePtr));
/* 363 */
EXTERN int		Tcl_ParseQuotedString _ANSI_ARGS_((
				Tcl_Interp * interp, char * string, 
				int numBytes, Tcl_Parse * parsePtr, 
				int append, char ** termPtr));
/* 364 */
EXTERN int		Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, 
				char * string, int numBytes, 
				Tcl_Parse * parsePtr, int append));
/* 365 */
EXTERN char *		Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
/* 366 */
EXTERN int		Tcl_Chdir _ANSI_ARGS_((CONST char * dirName));
/* 367 */







|

|


|
|


|



|

|


|







1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
EXTERN void		Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr));
/* 359 */
EXTERN void		Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * script, CONST char * command, 
				int length));
/* 360 */
EXTERN int		Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				Tcl_Parse * parsePtr, int append, 
				CONST84 char ** termPtr));
/* 361 */
EXTERN int		Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				int nested, Tcl_Parse * parsePtr));
/* 362 */
EXTERN int		Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				Tcl_Parse * parsePtr));
/* 363 */
EXTERN int		Tcl_ParseQuotedString _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * string, 
				int numBytes, Tcl_Parse * parsePtr, 
				int append, CONST84 char ** termPtr));
/* 364 */
EXTERN int		Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * string, int numBytes, 
				Tcl_Parse * parsePtr, int append));
/* 365 */
EXTERN char *		Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
/* 366 */
EXTERN int		Tcl_Chdir _ANSI_ARGS_((CONST char * dirName));
/* 367 */
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
EXTERN int		Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan, 
				CONST char * src, int srcLen));
/* 396 */
EXTERN Tcl_Channel	Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan));
/* 397 */
EXTERN int		Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan));
/* 398 */
EXTERN CONST char *	Tcl_ChannelName _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
/* 400 */
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));







|







1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
EXTERN int		Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan, 
				CONST char * src, int srcLen));
/* 396 */
EXTERN Tcl_Channel	Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan));
/* 397 */
EXTERN int		Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan));
/* 398 */
EXTERN CONST84_RETURN char * Tcl_ChannelName _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
/* 400 */
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc _ANSI_ARGS_((
				Tcl_ChannelType * chanTypePtr));
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
EXTERN int		Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr));
/* 444 */
EXTERN int		Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * pathPtr, CONST char * sym1, 
				CONST char * sym2, 
				Tcl_PackageInitProc ** proc1Ptr, 
				Tcl_PackageInitProc ** proc2Ptr, 
				ClientData * clientDataPtr, 
				Tcl_FSUnloadFileProc ** unloadProcPtr));
/* 445 */
EXTERN int		Tcl_FSMatchInDirectory _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * result, 
				Tcl_Obj * pathPtr, CONST char * pattern, 
				Tcl_GlobTypeData * types));
/* 446 */
EXTERN Tcl_Obj *	Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, 
				Tcl_Obj * toPtr));
/* 447 */
EXTERN int		Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, 
				int recursive, Tcl_Obj ** errorPtr));
/* 448 */
EXTERN int		Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, 
				Tcl_Obj * destPathPtr));
/* 449 */







|








|







1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
EXTERN int		Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr));
/* 444 */
EXTERN int		Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * pathPtr, CONST char * sym1, 
				CONST char * sym2, 
				Tcl_PackageInitProc ** proc1Ptr, 
				Tcl_PackageInitProc ** proc2Ptr, 
				Tcl_LoadHandle * handlePtr, 
				Tcl_FSUnloadFileProc ** unloadProcPtr));
/* 445 */
EXTERN int		Tcl_FSMatchInDirectory _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * result, 
				Tcl_Obj * pathPtr, CONST char * pattern, 
				Tcl_GlobTypeData * types));
/* 446 */
EXTERN Tcl_Obj *	Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, 
				Tcl_Obj * toPtr, int linkAction));
/* 447 */
EXTERN int		Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, 
				int recursive, Tcl_Obj ** errorPtr));
/* 448 */
EXTERN int		Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, 
				Tcl_Obj * destPathPtr));
/* 449 */
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
EXTERN Tcl_Obj*		Tcl_FSGetTranslatedPath _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj* pathPtr));
/* 467 */
EXTERN int		Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * fileName));
/* 468 */
EXTERN Tcl_Obj*		Tcl_FSNewNativePath _ANSI_ARGS_((
				Tcl_Obj* fromFilesystem, 
				ClientData clientData));
/* 469 */
EXTERN CONST char*	Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
/* 470 */
EXTERN Tcl_Obj*		Tcl_FSFileSystemInfo _ANSI_ARGS_((
				Tcl_Obj* pathObjPtr));
/* 471 */







|







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
EXTERN Tcl_Obj*		Tcl_FSGetTranslatedPath _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj* pathPtr));
/* 467 */
EXTERN int		Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * fileName));
/* 468 */
EXTERN Tcl_Obj*		Tcl_FSNewNativePath _ANSI_ARGS_((
				Tcl_Filesystem* fromFilesystem, 
				ClientData clientData));
/* 469 */
EXTERN CONST char*	Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
/* 470 */
EXTERN Tcl_Obj*		Tcl_FSFileSystemInfo _ANSI_ARGS_((
				Tcl_Obj* pathObjPtr));
/* 471 */
1564
1565
1566
1567
1568
1569
1570
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
} 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 */
    CONST char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved9;
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved9;
#endif /* MAC_TCL */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    void (*tcl_DeleteFileHandler) _ANSI_ARGS_((int fd)); /* 10 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved10;







|







|








|







1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
} TclStubHooks;

typedef struct TclStubs {
    int magic;
    struct TclStubHooks *hooks;

    int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
    CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
    void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
    char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
    void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
    char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
    char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
    int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
    char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved9;
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved9;
#endif /* MAC_TCL */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    void (*tcl_DeleteFileHandler) _ANSI_ARGS_((int fd)); /* 10 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved10;
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved10;
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
    int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */
    void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */
    void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */
    int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */
    int (*tcl_CommandComplete) _ANSI_ARGS_((char * cmd)); /* 82 */
    char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 83 */
    int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 84 */
    int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char * src, int length, char * dst, int flags)); /* 85 */
    int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, char * CONST * argv)); /* 86 */
    int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
    Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, CONST char * chanName, ClientData instanceData, int mask)); /* 88 */
    void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */
    void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */
    Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
    void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */
    void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */







|



|







1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
    int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
    void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
    char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
    int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */
    void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */
    void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */
    int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */
    int (*tcl_CommandComplete) _ANSI_ARGS_((CONST char * cmd)); /* 82 */
    char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 83 */
    int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 84 */
    int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char * src, int length, char * dst, int flags)); /* 85 */
    int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, CONST84 char * CONST * argv)); /* 86 */
    int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
    Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, CONST char * chanName, ClientData instanceData, int mask)); /* 88 */
    void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */
    void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */
    Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
    void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */
    void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
    int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
    void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
    void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
    void (*tcl_DeleteExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 107 */
    void (*tcl_DeleteHashEntry) _ANSI_ARGS_((Tcl_HashEntry * entryPtr)); /* 108 */
    void (*tcl_DeleteHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 109 */
    void (*tcl_DeleteInterp) _ANSI_ARGS_((Tcl_Interp * interp)); /* 110 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved111;







|







1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
    int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
    void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
    void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
    void (*tcl_DeleteExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 107 */
    void (*tcl_DeleteHashEntry) _ANSI_ARGS_((Tcl_HashEntry * entryPtr)); /* 108 */
    void (*tcl_DeleteHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 109 */
    void (*tcl_DeleteInterp) _ANSI_ARGS_((Tcl_Interp * interp)); /* 110 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved111;
1714
1715
1716
1717
1718
1719
1720
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
    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 */
    CONST char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
    CONST char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
    int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 129 */
    int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
    int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
    void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
    void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
    int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
    int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
    int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
    int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
    int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
    int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
    int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
    int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
    int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
    void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
    void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
    Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
    int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
    void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
    int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, char *** argvPtr)); /* 148 */
    int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
    ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
    Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanName, int * modePtr)); /* 151 */
    int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
    int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */
    ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */
    int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */
    CONST char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
    int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 157 */
    Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
    int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
    CONST char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
    int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
    CONST char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
    int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
    Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
    CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
    Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved167;
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved167;
#endif /* MAC_TCL */
    Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
    int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
    int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */
    int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */
    Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 172 */
    Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */
    CONST char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */
    CONST char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags)); /* 175 */
    CONST char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, int flags)); /* 176 */
    int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, char * command)); /* 177 */
    int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */
    int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */
    int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */
    void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */
    int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
    int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */
    int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */
    int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */
    char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 186 */
    int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); /* 187 */
    void *reserved188;
    Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */
    int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 190 */
    Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */
    char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 192 */
    Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch * searchPtr)); /* 193 */
    void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */
    Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 195 */
    Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); /* 196 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved197;
#endif /* MAC_TCL */
    Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
    Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
    Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
    void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
    void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
    int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */
    CONST char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
    void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
    int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved207;







|
|
|


















|







|



|

|




|














|
|
|
|









|









|














|


|







1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
    void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
    void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */
    void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */
    void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */
    void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
    void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
    int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
    CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
    CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
    int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */
    int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
    int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
    void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
    void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
    int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
    int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
    int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
    int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
    int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
    int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
    int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
    int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
    int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
    void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
    void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
    Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
    int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
    void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
    int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */
    int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
    ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
    Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanName, int * modePtr)); /* 151 */
    int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
    int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */
    ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */
    int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */
    CONST84_RETURN char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
    int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 157 */
    Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
    int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
    CONST84_RETURN char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
    int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
    CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
    int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
    Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
    CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
    Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
    void *reserved167;
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved167;
#endif /* MAC_TCL */
    Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
    int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
    int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */
    int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */
    Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 172 */
    Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */
    CONST84_RETURN char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */
    CONST84_RETURN char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 175 */
    CONST84_RETURN char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 176 */
    int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command)); /* 177 */
    int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */
    int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */
    int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */
    void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */
    int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
    int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */
    int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */
    int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */
    char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 186 */
    int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, char * addr, int type)); /* 187 */
    void *reserved188;
    Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */
    int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 190 */
    Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */
    char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 192 */
    Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch * searchPtr)); /* 193 */
    void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */
    Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 195 */
    Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); /* 196 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved197;
#endif /* MAC_TCL */
    Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
    Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
    Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
    void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
    void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
    int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */
    CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
    void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
    int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved207;
1848
1849
1850
1851
1852
1853
1854
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
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
    void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
    CONST char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, CONST char * newValue, int flags)); /* 237 */
    CONST char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
    CONST char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
    CONST char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
    void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */
    int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 242 */
    void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */
    void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
    int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */
    int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
    int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
    int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
    char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */
    int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 250 */
    void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 251 */
    int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 252 */
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, 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 */
    CONST char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
    CONST char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char ** termPtr)); /* 270 */
    CONST char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
    CONST 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 */
    CONST char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
    void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
    int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
    Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
    void (*tcl_PanicVA) _ANSI_ARGS_((CONST char * format, va_list argList)); /* 278 */
    void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */
    void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */
    Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
    int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
    Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
    void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
    void *reserved285;
    void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
    Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
    void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */
    void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */
    void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */
    int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, char * script, int numBytes, int flags)); /* 291 */
    int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
    int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */
    void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
    int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */
    char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */
    void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */
    void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */
    void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
    Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
    Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */
    CONST char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
    void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */
    int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 304 */
    VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
    Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, int flags)); /* 306 */
    ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
    void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
    void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
    void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
    void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
    int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */
    int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
    void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
    void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
    int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
    Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, 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 */
    CONST char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
    int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
    int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
    CONST char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
    CONST char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
    CONST char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
    CONST char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
    int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
    char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
    int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */
    int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */
    int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */
    int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */
    int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
    int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
    char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
    CONST char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
    void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char * path)); /* 342 */
    void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
    void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
    int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
    int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
    int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
    int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
    int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
    int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
    int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
    int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */
    int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */
    char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
    Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
    Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
    Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
    void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
    void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
    int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 360 */
    int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
    int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
    int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 363 */
    int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
    char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
    int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
    int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
    int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */
    int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */
    int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 370 */
    int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */







|
|
|
|






|
|


|

|
|
|
|
|
|
|

|
|






|
|
|
|

|
















|










|



|










|







|


|
|
|
|









|


















|
|
|
|
|







1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
    void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
    int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
    void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
    int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
    void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
    void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
    void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
    CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */
    CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
    CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
    CONST84_RETURN char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
    void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */
    int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 242 */
    void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */
    void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
    int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */
    int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
    int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
    int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
    char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */
    int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 250 */
    void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 251 */
    int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 252 */
    int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
    int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
    void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
    void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
    void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
    int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
    int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
    int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
    ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
    ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
    int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
    void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
    int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
    void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
    void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
    void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
    CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
    CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */
    CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
    CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */
    int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */
    CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
    void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
    int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
    Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
    void (*tcl_PanicVA) _ANSI_ARGS_((CONST char * format, va_list argList)); /* 278 */
    void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */
    void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */
    Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
    int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
    Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
    void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
    void *reserved285;
    void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
    Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
    void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */
    void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */
    void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */
    int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, int numBytes, int flags)); /* 291 */
    int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
    int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */
    void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
    int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */
    char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */
    void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */
    void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */
    void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
    Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
    Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */
    CONST84_RETURN char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
    void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */
    int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 304 */
    VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
    Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */
    ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
    void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
    void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
    void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
    void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
    int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */
    int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
    void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
    void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
    int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
    Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
    void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
    void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
    Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
    Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
    Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
    Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
    int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
    CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
    int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
    int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
    CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
    CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
    CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
    CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
    int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
    char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
    int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */
    int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */
    int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */
    int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */
    int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
    int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
    char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
    CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
    void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char * path)); /* 342 */
    void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
    void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
    int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
    int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
    int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
    int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
    int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
    int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
    int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
    int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */
    int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */
    char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
    Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
    Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
    Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
    void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
    void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
    int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */
    int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
    int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
    int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */
    int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
    char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
    int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
    int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
    int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */
    int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */
    int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 370 */
    int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
    void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
    void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
    int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
    int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */
    int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */
    Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
    int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
    CONST char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */
    Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 399 */
    Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 400 */
    Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 401 */
    Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 402 */
    Tcl_DriverInputProc * (*tcl_ChannelInputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 403 */
    Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 404 */
    Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 405 */







|







2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
    void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
    void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
    int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
    int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */
    int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */
    Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
    int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
    CONST84_RETURN char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */
    Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 399 */
    Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 400 */
    Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 401 */
    Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 402 */
    Tcl_DriverInputProc * (*tcl_ChannelInputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 403 */
    Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 404 */
    Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 405 */
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
    Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
    int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
    int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
    int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
    int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
    int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
    int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
    int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */
    int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */
    Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr)); /* 446 */
    int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */
    int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */
    int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */
    int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */
    int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */
    int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */
    CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */







|

|







2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
    Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
    int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
    int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
    int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
    int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
    int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
    int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
    int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, Tcl_LoadHandle * handlePtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */
    int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */
    Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkAction)); /* 446 */
    int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */
    int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */
    int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */
    int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */
    int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */
    int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */
    CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
    Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
    int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
    Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
    Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
    ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
    Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
    int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
    Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Obj* fromFilesystem, ClientData clientData)); /* 468 */
    CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
    Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
    Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
    Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
    int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
    int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
    ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */







|







2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
    Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
    int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
    Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
    Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
    ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
    Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
    int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
    Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 468 */
    CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
    Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
    Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
    Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
    int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
    int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
    ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
#define Tcl_DbCkfree \
	(tclStubsPtr->tcl_DbCkfree) /* 7 */
#endif
#ifndef Tcl_DbCkrealloc
#define Tcl_DbCkrealloc \
	(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef Tcl_CreateFileHandler
#define Tcl_CreateFileHandler \
	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif
#endif /* UNIX */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef Tcl_DeleteFileHandler
#define Tcl_DeleteFileHandler \
	(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif
#endif /* UNIX */
#ifndef Tcl_SetTimer
#define Tcl_SetTimer \







|





|







2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
#define Tcl_DbCkfree \
	(tclStubsPtr->tcl_DbCkfree) /* 7 */
#endif
#ifndef Tcl_DbCkrealloc
#define Tcl_DbCkrealloc \
	(tclStubsPtr->tcl_DbCkrealloc) /* 8 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_CreateFileHandler
#define Tcl_CreateFileHandler \
	(tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif
#endif /* UNIX */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_DeleteFileHandler
#define Tcl_DeleteFileHandler \
	(tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif
#endif /* UNIX */
#ifndef Tcl_SetTimer
#define Tcl_SetTimer \
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
#define Tcl_DeleteHashTable \
	(tclStubsPtr->tcl_DeleteHashTable) /* 109 */
#endif
#ifndef Tcl_DeleteInterp
#define Tcl_DeleteInterp \
	(tclStubsPtr->tcl_DeleteInterp) /* 110 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef Tcl_DetachPids
#define Tcl_DetachPids \
	(tclStubsPtr->tcl_DetachPids) /* 111 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef Tcl_DetachPids







|







2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
#define Tcl_DeleteHashTable \
	(tclStubsPtr->tcl_DeleteHashTable) /* 109 */
#endif
#ifndef Tcl_DeleteInterp
#define Tcl_DeleteInterp \
	(tclStubsPtr->tcl_DeleteInterp) /* 110 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_DetachPids
#define Tcl_DetachPids \
	(tclStubsPtr->tcl_DetachPids) /* 111 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef Tcl_DetachPids
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
#define Tcl_GetNameOfExecutable \
	(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#endif
#ifndef Tcl_GetObjResult
#define Tcl_GetObjResult \
	(tclStubsPtr->tcl_GetObjResult) /* 166 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef Tcl_GetOpenFile
#define Tcl_GetOpenFile \
	(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif
#endif /* UNIX */
#ifndef Tcl_GetPathType
#define Tcl_GetPathType \







|







2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
#define Tcl_GetNameOfExecutable \
	(tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#endif
#ifndef Tcl_GetObjResult
#define Tcl_GetObjResult \
	(tclStubsPtr->tcl_GetObjResult) /* 166 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_GetOpenFile
#define Tcl_GetOpenFile \
	(tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif
#endif /* UNIX */
#ifndef Tcl_GetPathType
#define Tcl_GetPathType \
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
#define Tcl_ObjGetVar2 \
	(tclStubsPtr->tcl_ObjGetVar2) /* 195 */
#endif
#ifndef Tcl_ObjSetVar2
#define Tcl_ObjSetVar2 \
	(tclStubsPtr->tcl_ObjSetVar2) /* 196 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef Tcl_OpenCommandChannel
#define Tcl_OpenCommandChannel \
	(tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef Tcl_OpenCommandChannel







|







2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
#define Tcl_ObjGetVar2 \
	(tclStubsPtr->tcl_ObjGetVar2) /* 195 */
#endif
#ifndef Tcl_ObjSetVar2
#define Tcl_ObjSetVar2 \
	(tclStubsPtr->tcl_ObjSetVar2) /* 196 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_OpenCommandChannel
#define Tcl_OpenCommandChannel \
	(tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef Tcl_OpenCommandChannel
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
#define Tcl_QueueEvent \
	(tclStubsPtr->tcl_QueueEvent) /* 205 */
#endif
#ifndef Tcl_Read
#define Tcl_Read \
	(tclStubsPtr->tcl_Read) /* 206 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef Tcl_ReapDetachedProcs
#define Tcl_ReapDetachedProcs \
	(tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef Tcl_ReapDetachedProcs







|







2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
#define Tcl_QueueEvent \
	(tclStubsPtr->tcl_QueueEvent) /* 205 */
#endif
#ifndef Tcl_Read
#define Tcl_Read \
	(tclStubsPtr->tcl_Read) /* 206 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_ReapDetachedProcs
#define Tcl_ReapDetachedProcs \
	(tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef Tcl_ReapDetachedProcs
Changes to generic/tclEnv.c.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.9.14.2 2002/06/10 05:33:11 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */








|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.9.14.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#endif

/*
 * Declarations for local procedures defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, 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));









|
|







42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#endif

/*
 * Declarations for local procedures defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
			    CONST char *name2, int flags));
static void		ReplaceString _ANSI_ARGS_((CONST char *oldStr,
			    char *newStr));
void			TclSetEnv _ANSI_ARGS_((CONST char *name,
			    CONST char *value));
void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));


516
517
518
519
520
521
522
523
524
525
526
527
528
529
530

	/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
				 * being modified. */
    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.
     */







|







516
517
518
519
520
521
522
523
524
525
526
527
528
529
530

	/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
				 * being modified. */
    CONST char *name1;		/* Better be "env". */
    CONST char *name2;		/* Name of variable being modified, or NULL
				 * if whole array is being deleted (UTF-8). */
    int flags;			/* Indicates what's happening. */
{
    /*
     * For array traces, let TclSetupEnv do all the work.
     */
Changes to generic/tclEvent.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclEvent.c --
 *
 *	This file implements some general event related interfaces including
 *	background errors, exit handlers, and the "vwait" and "update"
 *	command procedures. 
 *
 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEvent.c,v 1.15.2.2 2002/06/10 05:33:11 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The data structure below is used to report background errors.  One













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclEvent.c --
 *
 *	This file implements some general event related interfaces including
 *	background errors, exit handlers, and the "vwait" and "update"
 *	command procedures. 
 *
 * Copyright (c) 1990-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEvent.c,v 1.15.2.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The data structure below is used to report background errors.  One
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
 * Prototypes for procedures referenced only in this file:
 */

static void		BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static void		HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char *		VwaitVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, char *name1, CONST char *name2,
			    int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BackgroundError --
 *
 *	This procedure is invoked to handle errors that occur in Tcl







|
|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
 * Prototypes for procedures referenced only in this file:
 */

static void		BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static void		HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char *		VwaitVarProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
			    CONST char *name2, int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_BackgroundError --
 *
 *	This procedure is invoked to handle errors that occur in Tcl
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
 */

static void
HandleBgErrors(clientData)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
{
    Tcl_Interp *interp;
    char *argv[2];
    int code;
    BgError *errPtr;
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    Tcl_Channel errChannel;

    Tcl_Preserve((ClientData) assocPtr);
    







|







218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
 */

static void
HandleBgErrors(clientData)
    ClientData clientData;	/* Pointer to ErrAssocData structure. */
{
    Tcl_Interp *interp;
    CONST char *argv[2];
    int code;
    BgError *errPtr;
    ErrAssocData *assocPtr = (ErrAssocData *) clientData;
    Tcl_Channel errChannel;

    Tcl_Preserve((ClientData) assocPtr);
    
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
}

	/* ARGSUSED */
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Pointer to integer to set to 1. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *name1;		/* Name of variable. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    int *donePtr = (int *) clientData;

    *donePtr = 1;
    return (char *) NULL;







|







1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
}

	/* ARGSUSED */
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Pointer to integer to set to 1. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    int *donePtr = (int *) clientData;

    *donePtr = 1;
    return (char *) NULL;
Changes to generic/tclExecute.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclExecute.c --
 *
 *	This file contains procedures that execute byte-compiled Tcl
 *	commands.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.34.4.2 2002/06/10 05:33:11 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

#ifndef TCL_NO_MATH
#   include "tclMath.h"













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclExecute.c --
 *
 *	This file contains procedures that execute byte-compiled Tcl
 *	commands.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclExecute.c,v 1.34.4.3 2002/08/20 20:25:25 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

#ifndef TCL_NO_MATH
#   include "tclMath.h"
124
125
126
127
128
129
130
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
 * by comparing against the largest floating-point value.
 */

#define IS_NAN(v) ((v) != (v))
#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))

/*
 * Macro to adjust the program counter and restart the instruction execution
 * loop after each instruction is executed.











 */






























#define ADJUST_PC(instBytes) \

    pc += (instBytes); \









    continue

/*
 * Macros used to cache often-referenced Tcl evaluation stack information
 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
 * pair must surround any call inside TclExecuteByteCode (and a few other
 * procedures that use this scheme) that could result in a recursive call
 * to TclExecuteByteCode.
 */

#define CACHE_STACK_INFO() \
    stackPtr = eePtr->stackPtr; \
    stackTop = eePtr->stackTop

#define DECACHE_STACK_INFO() \
    eePtr->stackTop = stackTop


/*
 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 * increments the object's ref count since it makes the stack have another
 * reference pointing to the object. However, POP_OBJECT does not decrement
 * the ref count. This is because the stack may hold the only reference to
 * the object, so the object would be destroyed if its ref count were







<
|
>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
|















>







124
125
126
127
128
129
130

131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
 * by comparing against the largest floating-point value.
 */

#define IS_NAN(v) ((v) != (v))
#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))

/*

 * The new macro for ending an instruction; note that a
 * reasonable C-optimiser will resolve all branches
 * at compile time. (result) is always a constant; the macro 
 * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
 * resolved at runtime for variable (nCleanup).
 *
 * ARGUMENTS:
 *    pcAdjustment: how much to increment pc
 *    nCleanup: how many objects to remove from the stack
 *    result: 0 indicates no object should be pushed on the
 *       stack; otherwise, push objResultPtr. If (result < 0),
 *       objResultPtr already has the correct reference count.
 */

#define NEXT_INST_F(pcAdjustment, nCleanup, result) \
     if (nCleanup == 0) {\
	 if (result != 0) {\
	     if ((result) > 0) {\
		 PUSH_OBJECT(objResultPtr);\
	     } else {\
		 stackPtr[++stackTop] = objResultPtr;\
	     }\
	 } \
	 pc += (pcAdjustment);\
	 goto cleanup0;\
     } else if (result != 0) {\
	 if ((result) > 0) {\
	     Tcl_IncrRefCount(objResultPtr);\
	 }\
	 pc += (pcAdjustment);\
	 switch (nCleanup) {\
	     case 1: goto cleanup1_pushObjResultPtr;\
	     case 2: goto cleanup2_pushObjResultPtr;\
	     default: panic("ERROR: bad usage of macro NEXT_INST_F");\
	 }\
     } else {\
	 pc += (pcAdjustment);\
	 switch (nCleanup) {\
	     case 1: goto cleanup1;\
	     case 2: goto cleanup2;\
	     default: panic("ERROR: bad usage of macro NEXT_INST_F");\
	 }\
     }

#define NEXT_INST_V(pcAdjustment, nCleanup, result) \
    pc += (pcAdjustment);\
    cleanup = (nCleanup);\
    if (result) {\
	if ((result) > 0) {\
	    Tcl_IncrRefCount(objResultPtr);\
	}\
	goto cleanupV_pushObjResultPtr;\
    } else {\
	goto cleanupV;\
    }


/*
 * Macros used to cache often-referenced Tcl evaluation stack information
 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
 * pair must surround any call inside TclExecuteByteCode (and a few other
 * procedures that use this scheme) that could result in a recursive call
 * to TclExecuteByteCode.
 */

#define CACHE_STACK_INFO() \
    stackPtr = eePtr->stackPtr; \
    stackTop = eePtr->stackTop

#define DECACHE_STACK_INFO() \
    eePtr->stackTop = stackTop


/*
 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 * increments the object's ref count since it makes the stack have another
 * reference pointing to the object. However, POP_OBJECT does not decrement
 * the ref count. This is because the stack may hold the only reference to
 * the object, so the object would be destroyed if its ref count were
181
182
183
184
185
186
187




188
189
190
191
192
193
194
195
196
197
198
199
200
201

202
203
204
205
206
207
208
#ifdef TCL_COMPILE_DEBUG
#   define TRACE(a) \
    if (traceInstructions) { \
        fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
	       (unsigned int)(pc - codePtr->codeStart), \
	       GetOpcodeName(pc)); \
	printf a; \




    }
#   define TRACE_WITH_OBJ(a, objPtr) \
    if (traceInstructions) { \
        fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
	       (unsigned int)(pc - codePtr->codeStart), \
	       GetOpcodeName(pc)); \
	printf a; \
        TclPrintObject(stdout, objPtr, 30); \
        fprintf(stdout, "\n"); \
    }
#   define O2S(objPtr) \
    (objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
#   define TRACE(a)

#   define TRACE_WITH_OBJ(a, objPtr)
#   define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */


/*
 * Most of the code to support working with wide values is factored







>
>
>
>














>







231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
#ifdef TCL_COMPILE_DEBUG
#   define TRACE(a) \
    if (traceInstructions) { \
        fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
	       (unsigned int)(pc - codePtr->codeStart), \
	       GetOpcodeName(pc)); \
	printf a; \
    }
#   define TRACE_APPEND(a) \
    if (traceInstructions) { \
	printf a; \
    }
#   define TRACE_WITH_OBJ(a, objPtr) \
    if (traceInstructions) { \
        fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
	       (unsigned int)(pc - codePtr->codeStart), \
	       GetOpcodeName(pc)); \
	printf a; \
        TclPrintObject(stdout, objPtr, 30); \
        fprintf(stdout, "\n"); \
    }
#   define O2S(objPtr) \
    (objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
#   define TRACE(a)
#   define TRACE_APPEND(a) 
#   define TRACE_WITH_OBJ(a, objPtr)
#   define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */


/*
 * Most of the code to support working with wide values is factored
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363

/*
 * Table describing the built-in math functions. Entries in this table are
 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte.
 */

BuiltinFunc builtinFuncTable[] = {
#ifndef TCL_NO_MATH
    {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
    {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
    {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
    {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
    {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
    {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},







|







404
405
406
407
408
409
410
411
412
413
414
415
416
417
418

/*
 * Table describing the built-in math functions. Entries in this table are
 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
 * operand byte.
 */

BuiltinFunc tclBuiltinFuncTable[] = {
#ifndef TCL_NO_MATH
    {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
    {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
    {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
    {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
    {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
    {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
454
455
456
457
458
459
460

461
462
463










464
465






466
467
468
469
470
471
472

ExecEnv *
TclCreateExecEnv(interp)
    Tcl_Interp *interp;		/* Interpreter for which the execution
				 * environment is being created. */
{
    ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));


    eePtr->stackPtr = (Tcl_Obj **)
	ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));










    eePtr->stackTop = -1;
    eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);







    Tcl_MutexLock(&execMutex);
    if (!execInitialized) {
	TclInitAuxDataTypeTable();
	InitByteCodeExecution(interp);
	execInitialized = 1;
    }







>

|
|
>
>
>
>
>
>
>
>
>
>

|
>
>
>
>
>
>







509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544

ExecEnv *
TclCreateExecEnv(interp)
    Tcl_Interp *interp;		/* Interpreter for which the execution
				 * environment is being created. */
{
    ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
    Tcl_Obj **stackPtr;

    stackPtr = (Tcl_Obj **)
	ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));

    /*
     * Use the bottom pointer to keep a reference count; the 
     * execution environment holds a reference.
     */

    stackPtr++;
    eePtr->stackPtr = stackPtr;
    stackPtr[-1] = (Tcl_Obj *) ((char *) 1);

    eePtr->stackTop = -1;
    eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);

    eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
    Tcl_IncrRefCount(eePtr->errorInfo);

    eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
    Tcl_IncrRefCount(eePtr->errorCode);

    Tcl_MutexLock(&execMutex);
    if (!execInitialized) {
	TclInitAuxDataTypeTable();
	InitByteCodeExecution(interp);
	execInitialized = 1;
    }
493
494
495
496
497
498
499

500





501
502
503
504
505
506
507
 *----------------------------------------------------------------------
 */

void
TclDeleteExecEnv(eePtr)
    ExecEnv *eePtr;		/* Execution environment to free. */
{

    Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);





    ckfree((char *) eePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeExecution --







>
|
>
>
>
>
>







565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
 *----------------------------------------------------------------------
 */

void
TclDeleteExecEnv(eePtr)
    ExecEnv *eePtr;		/* Execution environment to free. */
{
    if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
	ckfree((char *) (eePtr->stackPtr-1));
    } else {
	panic("ERROR: freeing an execEnv whose stack is still in use.\n");
    }
    TclDecrRefCount(eePtr->errorInfo);
    TclDecrRefCount(eePtr->errorCode);
    ckfree((char *) eePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeExecution --
555
556
557
558
559
560
561








562
563
564
565

566
567

568
569
570











571
572

573
574
575
576
577
578
579
     */

    int currElems = (eePtr->stackEnd + 1);
    int newElems  = 2*currElems;
    int currBytes = currElems * sizeof(Tcl_Obj *);
    int newBytes  = 2*currBytes;
    Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);









    /*
     * Copy the existing stack items to the new stack space, free the old
     * storage if appropriate, and mark new space as malloc'ed.

     */
 

    memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
	   (size_t) currBytes);
    Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);











    eePtr->stackPtr = newStackPtr;
    eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */

}

/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprObj --
 *







>
>
>
>
>
>
>
>



|
>


>
|

|
>
>
>
>
>
>
>
>
>
>
>

|
>







633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
     */

    int currElems = (eePtr->stackEnd + 1);
    int newElems  = 2*currElems;
    int currBytes = currElems * sizeof(Tcl_Obj *);
    int newBytes  = 2*currBytes;
    Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
    Tcl_Obj **oldStackPtr = eePtr->stackPtr;

    /*
     * We keep the stack reference count as a (char *), as that
     * works nicely as a portable pointer-sized counter.
     */

    char *refCount = (char *) oldStackPtr[-1];

    /*
     * Copy the existing stack items to the new stack space, free the old
     * storage if appropriate, and record the refCount of the new stack
     * held by the environment.
     */
 
    newStackPtr++;
    memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
	   (size_t) currBytes);

    if (refCount == (char *) 1) {
	ckfree((VOID *) (oldStackPtr-1));
    } else {
	/*
	 * Remove the reference corresponding to the
	 * environment pointer.
	 */
	
	oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
    }

    eePtr->stackPtr = newStackPtr;
    eePtr->stackEnd = (newElems - 2); /* index of last usable item */
    newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);	
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_ExprObj --
 *
822
823
824
825
826
827
828
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
     * Check that the interpreter is ready to execute scripts
     */

    if (TclInterpReady(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }

    /*
     * 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,
     * or for a different namespace, or for the same namespace but
     * with different name resolution rules, we recompile it.
     *
     * 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.
     */

    if (iPtr->varFramePtr != NULL) {
        namespacePtr = iPtr->varFramePtr->nsPtr;
    } else {
        namespacePtr = iPtr->globalNsPtr;
    }








    if (objPtr->typePtr == &tclByteCodeType) {







	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;










	








	if (((Interp *) *codePtr->interpHandle != iPtr)
	        || (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION	/* [Bug: 3412 Pedantic] */
		|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
			iPtr->varFramePtr->procPtr == codePtr->procPtr))
#endif
	        || (codePtr->nsPtr != namespacePtr)
	        || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
                if ((Interp *) *codePtr->interpHandle != iPtr) {
                    panic("Tcl_EvalObj: compiled script jumped interps");
                }
	        codePtr->compileEpoch = iPtr->compileEpoch;
            } else {



                tclByteCodeType.freeIntRepProc(objPtr);
            }
	}
    }
    if (objPtr->typePtr != &tclByteCodeType) {
	iPtr->errorLine = 1; 
	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    return result;
	}
    } else {
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
	        || (codePtr->compileEpoch != iPtr->compileEpoch)) {
	    (*tclByteCodeType.freeIntRepProc)(objPtr);
	    iPtr->errorLine = 1; 
	    result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
	    if (result != TCL_OK) {
		return result;
	    }
	}
    }
    codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;

    /*
     * Extract then reset the compilation flags in the interpreter.
     * Resetting the flags must be done after any compilation.
     */

    iPtr->evalFlags = 0;

    /*
     * Execute the commands. If the code was compiled from an empty string,
     * don't bother executing the code.
     */

    numSrcBytes = codePtr->numSrcBytes;







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






>
>
>
>
>
>
>
|
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>














>
>
>

<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<



<
<
<
<
<
<
<
<







922
923
924
925
926
927
928




















929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987












988





989
990
991








992
993
994
995
996
997
998
     * Check that the interpreter is ready to execute scripts
     */

    if (TclInterpReady(interp) == TCL_ERROR) {
	return TCL_ERROR;
    }





















    if (iPtr->varFramePtr != NULL) {
        namespacePtr = iPtr->varFramePtr->nsPtr;
    } else {
        namespacePtr = iPtr->globalNsPtr;
    }

    /* 
     * If the object is not already of tclByteCodeType, compile it (and
     * reset the compilation flags in the interpreter; this should be 
     * done after any compilation).
     * Otherwise, check that it is "fresh" enough.
     */

    if (objPtr->typePtr != &tclByteCodeType) {
        recompileObj:
	iPtr->errorLine = 1; 
	result = tclByteCodeType.setFromAnyProc(interp, objPtr);
	if (result != TCL_OK) {
	    return result;
	}
	iPtr->evalFlags = 0;
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
    } else {
	/*
	 * Make sure the Bytecode hasn't been invalidated by, e.g., someone 
	 * redefining a command with a compile procedure (this might make the 
	 * compiled code wrong). 
	 * The object needs to be recompiled if it was compiled in/for a 
	 * different interpreter, or for a different namespace, or for the 
	 * same namespace but with different name resolution rules. 
	 * Precompiled objects, however, are immutable and therefore
	 * they are not recompiled, even if the epoch has changed.
	 *
	 * To be pedantically correct, we should also check that the
	 * originating procPtr is the same as the current context procPtr
	 * (assuming one exists at all - none for global level).  This
	 * code is #def'ed out because [info body] was changed to never
	 * return a bytecode type object, which should obviate us from
	 * the extra checks here.
	 */
	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
	if (((Interp *) *codePtr->interpHandle != iPtr)
	        || (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION	/* [Bug: 3412 Pedantic] */
		|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
			iPtr->varFramePtr->procPtr == codePtr->procPtr))
#endif
	        || (codePtr->nsPtr != namespacePtr)
	        || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
            if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
                if ((Interp *) *codePtr->interpHandle != iPtr) {
                    panic("Tcl_EvalObj: compiled script jumped interps");
                }
	        codePtr->compileEpoch = iPtr->compileEpoch;
            } else {
		/*
		 * This byteCode is invalid: free it and recompile
		 */
                tclByteCodeType.freeIntRepProc(objPtr);












		goto recompileObj;





	    }
	}
    }









    /*
     * Execute the commands. If the code was compiled from an empty string,
     * don't bother executing the code.
     */

    numSrcBytes = codePtr->numSrcBytes;
989
990
991
992
993
994
995
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
    				/* Points to the execution environment. */
    register Tcl_Obj **stackPtr = eePtr->stackPtr;
    				/* Cached evaluation stack base pointer. */
    register int stackTop = eePtr->stackTop;
    				/* Cached top index of evaluation stack. */
    register unsigned char *pc = codePtr->codeStart;
				/* The current program counter. */
    int opnd;			/* Current instruction's operand byte. */
    int pcAdjustment;		/* Hold pc adjustment after instruction. */
    int initStackTop = stackTop;/* Stack top at start of execution. */
    ExceptionRange *rangePtr;	/* Points to closest loop or catch exception
				 * range enclosing the pc. Used by various
				 * instructions and processCatch to
				 * process break, continue, and errors. */
    int result = TCL_OK;	/* Return code returned after execution. */
#ifdef TCL_COMPILE_DEBUG
    int traceInstructions = (tclTraceExec == 3);
#endif
    Tcl_Obj *valuePtr, *value2Ptr, *objPtr, *elemPtr;
    char *bytes;
    int length;
    long i = 0;			/* Init. avoids compiler warning. */
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt w;









#endif

    /*
     * This procedure uses a stack to hold information about catch commands.
     * This information is the current operand stack top when starting to
     * execute the code for each catch command. It starts out with stack-
     * allocated space but uses dynamically-allocated storage if needed.
     */

#define STATIC_CATCH_STACK_SIZE 4
    int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
    int *catchStackPtr = catchStackStorage;
    int catchTop = -1;

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 2) {
	PrintByteCodeInfo(codePtr);
	fprintf(stdout, "  Starting stack top=%d\n", eePtr->stackTop);
	fflush(stdout);
    }

#endif
    
#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    /*







|







<
|
<
|





>
>
>
>
>
>
>
>
>




















>







1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093

1094

1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
    				/* Points to the execution environment. */
    register Tcl_Obj **stackPtr = eePtr->stackPtr;
    				/* Cached evaluation stack base pointer. */
    register int stackTop = eePtr->stackTop;
    				/* Cached top index of evaluation stack. */
    register unsigned char *pc = codePtr->codeStart;
				/* The current program counter. */
    int opnd;			/* Current instruction's operand byte(s). */
    int pcAdjustment;		/* Hold pc adjustment after instruction. */
    int initStackTop = stackTop;/* Stack top at start of execution. */
    ExceptionRange *rangePtr;	/* Points to closest loop or catch exception
				 * range enclosing the pc. Used by various
				 * instructions and processCatch to
				 * process break, continue, and errors. */
    int result = TCL_OK;	/* Return code returned after execution. */

    int storeFlags;

    Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
    char *bytes;
    int length;
    long i = 0;			/* Init. avoids compiler warning. */
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt w;
#endif
    register int cleanup;
    Tcl_Obj *objResultPtr;
    char *part1, *part2;
    Var *varPtr, *arrayPtr;
    CallFrame *varFramePtr = iPtr->varFramePtr;
#ifdef TCL_COMPILE_DEBUG
    int traceInstructions = (tclTraceExec == 3);
    char cmdNameBuf[21];
#endif

    /*
     * This procedure uses a stack to hold information about catch commands.
     * This information is the current operand stack top when starting to
     * execute the code for each catch command. It starts out with stack-
     * allocated space but uses dynamically-allocated storage if needed.
     */

#define STATIC_CATCH_STACK_SIZE 4
    int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
    int *catchStackPtr = catchStackStorage;
    int catchTop = -1;

#ifdef TCL_COMPILE_DEBUG
    if (tclTraceExec >= 2) {
	PrintByteCodeInfo(codePtr);
	fprintf(stdout, "  Starting stack top=%d\n", eePtr->stackTop);
	fflush(stdout);
    }
    opnd = 0;			/* Init. avoids compiler warning. */       
#endif
    
#ifdef TCL_COMPILE_STATS
    iPtr->stats.numExecutions++;
#endif

    /*
1053
1054
1055
1056
1057
1058
1059
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

    while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
        GrowEvaluationStack(eePtr); 
        stackPtr = eePtr->stackPtr;
    }

    /*
     * Loop executing instructions until a "done" instruction, a TCL_RETURN,
     * or some error.
     */


    for (;;) {



























































#ifdef TCL_COMPILE_DEBUG
	ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
        if (traceInstructions) {
            fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
            TclPrintInstruction(codePtr, pc);
            fflush(stdout);
        }
#endif /* TCL_COMPILE_DEBUG */
	
#ifdef TCL_COMPILE_STATS    
	iPtr->stats.instructionCount[*pc]++;
#endif
        switch (*pc) {
	case INST_DONE:
	    if (stackTop <= initStackTop) {

		goto abnormalReturn;
	    }

	    /*
	     * Set the interpreter's object result to point to the 
	     * topmost object from the stack, and check for a possible
	     * [catch]. The stackTop's level and refCount will be handled 
	     * by "processCatch" or "abnormalReturn".
	     */

	    valuePtr = stackPtr[stackTop];
	    Tcl_SetObjResult(interp, valuePtr);

	    TRACE_WITH_OBJ(("=> return code=%d, result=", result),
		    iPtr->objResultPtr);
#ifdef TCL_COMPILE_DEBUG	    
	    if (traceInstructions) {
		fprintf(stdout, "\n");
	    }
#endif
	    goto checkForCatch;

	case INST_PUSH1:
#ifdef TCL_COMPILE_DEBUG
	    valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
#else
	    PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
#endif /* TCL_COMPILE_DEBUG */
	    ADJUST_PC(2);

	case INST_PUSH4:
	    valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
	    ADJUST_PC(5);

	case INST_POP:

	    valuePtr = POP_OBJECT();
	    TRACE_WITH_OBJ(("=> discarding "), valuePtr);
	    TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
	    ADJUST_PC(1);

	case INST_DUP:
	    valuePtr = stackPtr[stackTop];
	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("=> "), valuePtr);
	    ADJUST_PC(1);

	case INST_OVER:
	    opnd = TclGetUInt4AtPtr( pc+1 );
	    valuePtr = stackPtr[ stackTop - opnd ];
	    PUSH_OBJECT( valuePtr );
	    TRACE_WITH_OBJ(("=> "), valuePtr);
	    ADJUST_PC( 5 );

	case INST_CONCAT1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    {
		Tcl_Obj *concatObjPtr;
		int totalLen = 0;

		/*
		 * Concatenate strings (with no separators) from the top
		 * opnd items on the stack starting with the deepest item.
		 * First, determine how many characters are needed.
		 */

		for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
		    bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
		    if (bytes != NULL) {
			totalLen += length;
		    }
                }

		/*
		 * Initialize the new append string object by appending the
		 * strings of the opnd stack objects. Also pop the objects. 
		 */

		TclNewObj(concatObjPtr);
		if (totalLen > 0) {
		    char *p = (char *) ckalloc((unsigned) (totalLen + 1));
		    concatObjPtr->bytes = p;
		    concatObjPtr->length = totalLen;
		    for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
			valuePtr = stackPtr[i];
			bytes = Tcl_GetStringFromObj(valuePtr, &length);
			if (bytes != NULL) {
			    memcpy((VOID *) p, (VOID *) bytes,
			            (size_t) length);
			    p += length;
			}
			TclDecrRefCount(valuePtr);
		    }
		    *p = '\0';
		} else {
		    for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
			TclDecrRefCount(stackPtr[i]);
		    }
		}
		stackTop -= opnd;
		
		PUSH_OBJECT(concatObjPtr);
		TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
		ADJUST_PC(2);
            }
	    
	case INST_INVOKE_STK4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doInvocation;

	case INST_INVOKE_STK1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    
	    doInvocation:
	    {
		int objc = opnd; /* The number of arguments. */
		Tcl_Obj **objv;	 /* The array of argument objects. */
		int newPcOffset; /* New inst offset for break, continue. */





		Tcl_Obj **preservedStack;


				 /* Reference to memory block containing
				  * objv array (must be kept live throughout
				  * trace and command invokations.) */

#ifdef TCL_COMPILE_DEBUG
		char cmdNameBuf[21];
#endif
		objv = &(stackPtr[stackTop - (objc-1)]);

#ifdef TCL_COMPILE_DEBUG
		if (tclTraceExec >= 2) {
		    if (traceInstructions) {
			strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
			TRACE(("%u => call ", objc));
		    } else {
			fprintf(stdout, "%d: (%u) invoking ",
			        iPtr->numLevels,
				(unsigned int)(pc - codePtr->codeStart));
		    }
		    for (i = 0;  i < objc;  i++) {
			TclPrintObject(stdout, objv[i], 15);
			fprintf(stdout, " ");
		    }
		    fprintf(stdout, "\n");
		    fflush(stdout);
		}
#endif /*TCL_COMPILE_DEBUG*/

		/* 
		 * If trace procedures will be called, we need a
		 * command string to pass to TclEvalObjvInternal; note 
		 * that a copy of the string will be made there to 
		 * include the ending \0.
		 */

		bytes = NULL;
		length = 0;
		if (iPtr->tracePtr != NULL) {
		    Trace *tracePtr, *nextTracePtr;
		    
		    for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
		            tracePtr = nextTracePtr) {
			nextTracePtr = tracePtr->nextPtr;

			if (iPtr->numLevels <= tracePtr->level) {
			    /*
			     * Traces will be called: get command string
			     */

			    bytes = GetSrcInfoForPc(pc, codePtr, &length);
			    break;
			}
		    }





		}		


		/*
		 * A reference to part of the stack vector itself
		 * escapes our control, so must use preserve/release
		 * 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.
		 */

		Tcl_Preserve((ClientData)stackPtr);
		preservedStack = stackPtr;

		/*
		 * Finally, let TclEvalObjvInternal handle the command. 
		 */

		Tcl_ResetResult(interp);
		DECACHE_STACK_INFO();
		result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
		CACHE_STACK_INFO();

		/*
		 * If the old stack is going to be released, it is
		 * safe to do so now, since no references to objv are
		 * going to be used from now on.
		 */

		Tcl_Release((ClientData) preservedStack);
		
		/*
		 * Pop the objc top stack elements and decrement their ref
		 * counts. 
		 */

		for (i = 0;  i < objc;  i++) {
		    valuePtr = POP_OBJECT();
		    TclDecrRefCount(valuePtr);
		}

		/*
		 * Process the result of the Tcl_ObjCmdProc call.
		 */
		
		switch (result) {
		case TCL_OK:
		    /*
		     * Push the call's object result and continue execution
		     * with the next instruction.
		     */
		    PUSH_OBJECT(Tcl_GetObjResult(interp));
		    TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
		            objc, cmdNameBuf), Tcl_GetObjResult(interp));
		    ADJUST_PC(pcAdjustment);
		    
		case TCL_BREAK:
		case TCL_CONTINUE:
		    /*
		     * The invoked command requested a break or continue.
		     * Find the closest enclosing loop or catch exception
		     * range, if any. If a loop is found, terminate its
		     * execution or skip to its next iteration. If the
		     * closest is a catch exception range, jump to its
		     * catchOffset. If no enclosing range is found, stop
		     * execution and return the TCL_BREAK or TCL_CONTINUE.
		     */
		    rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
			    codePtr);
		    if (rangePtr == NULL) {
		        TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
		                objc, cmdNameBuf,
			        StringForResultCode(result)));
			goto abnormalReturn; /* no catch exists to check */
		    }
		    newPcOffset = 0;
		    switch (rangePtr->type) {
		    case LOOP_EXCEPTION_RANGE:
			if (result == TCL_BREAK) {
			    newPcOffset = rangePtr->breakOffset;
			} else if (rangePtr->continueOffset == -1) {
			    TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
				   objc, cmdNameBuf,
				   StringForResultCode(result)));
			    goto checkForCatch;

			} else {
			    newPcOffset = rangePtr->continueOffset;
			}
			TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
			       objc, cmdNameBuf,
			       StringForResultCode(result),
			       rangePtr->codeOffset, newPcOffset));
			break;
		    case CATCH_EXCEPTION_RANGE:
			TRACE(("%u => ... after \"%.20s\", %s...\n",
			       objc, cmdNameBuf,
			       StringForResultCode(result)));
			goto processCatch; /* it will use rangePtr */
		    default:
			panic("TclExecuteByteCode: bad ExceptionRange type\n");
		    }
		    result = TCL_OK;
		    pc = (codePtr->codeStart + newPcOffset);
		    continue;	/* restart outer instruction loop at pc */
		    
		case TCL_ERROR:
		    /*
		     * The invoked command returned an error. Look for an
		     * enclosing catch exception range, if any.
		     */
		    TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
		            objc, cmdNameBuf), Tcl_GetObjResult(interp));
		    goto checkForCatch;

		case TCL_RETURN:
		    /*
		     * The invoked command requested that the current


		     * procedure stop execution and return. First check
		     * for an enclosing catch exception range, if any.
		     */
		    TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
		            objc, cmdNameBuf));
		    goto checkForCatch;

		default:
		    TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
		            objc, cmdNameBuf, result),
			    Tcl_GetObjResult(interp));
		    goto checkForCatch;
		}
	    }
	    
	case INST_EVAL_STK:
	    objPtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    result = TclCompEvalObj(interp, objPtr);
	    CACHE_STACK_INFO();
	    if (result == TCL_OK) {
		/*
		 * Normal return; push the eval's object result.
		 */

		PUSH_OBJECT(Tcl_GetObjResult(interp));
		TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		ADJUST_PC(1);
	    } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
		/*
		 * Find the closest enclosing loop or catch exception range,
		 * if any. If a loop is found, terminate its execution or
		 * skip to its next iteration. If the closest is a catch
		 * exception range, jump to its catchOffset. If no enclosing
		 * range is found, stop execution and return that same
		 * TCL_BREAK or TCL_CONTINUE.
		 */

		int newPcOffset = 0; /* Pc offset computed during break,
				      * continue, error processing. Init.
				      * to avoid compiler warning. */

		rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
			codePtr);
		if (rangePtr == NULL) {
		    TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
			    O2S(objPtr), StringForResultCode(result)));
		    TclDecrRefCount(objPtr);
		    goto abnormalReturn;    /* no catch exists to check */
		}
		switch (rangePtr->type) {
		case LOOP_EXCEPTION_RANGE:
		    if (result == TCL_BREAK) {
			newPcOffset = rangePtr->breakOffset;
		    } else if (rangePtr->continueOffset == -1) {
			TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
			       O2S(objPtr), StringForResultCode(result)));
			TclDecrRefCount(objPtr);
			goto checkForCatch;
		    } else {
			newPcOffset = rangePtr->continueOffset;
		    }
		    result = TCL_OK;
		    TRACE(("\"%.30s\" => %s, range at %d, new pc %d ",
			    O2S(objPtr), StringForResultCode(result),
			    rangePtr->codeOffset, newPcOffset));
		    break;
		case CATCH_EXCEPTION_RANGE:
		    TRACE(("\"%.30s\" => %s ",
			    O2S(objPtr), StringForResultCode(result)));
		    TclDecrRefCount(objPtr);
		    goto processCatch;  /* it will use rangePtr */
		default:
		    panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
		}
		TclDecrRefCount(objPtr);
		pc = (codePtr->codeStart + newPcOffset);
		continue;	/* restart outer instruction loop at pc */
	    } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
		TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
		        Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		goto checkForCatch;
	    }

	case INST_EXPR_STK:
	    objPtr = POP_OBJECT();
	    Tcl_ResetResult(interp);
	    DECACHE_STACK_INFO();
	    result = Tcl_ExprObj(interp, objPtr, &valuePtr);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", 
		        O2S(objPtr)), Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		goto checkForCatch;
	    }
	    stackPtr[++stackTop] = valuePtr; /* already has right refct */
	    TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);

	    TclDecrRefCount(objPtr);
	    ADJUST_PC(1);









	case INST_LOAD_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    DECACHE_STACK_INFO();



	    valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG);

	    CACHE_STACK_INFO();

	    if (valuePtr == NULL) {
		TRACE_WITH_OBJ(("%u => ERROR: ", opnd),



		        Tcl_GetObjResult(interp));



		result = TCL_ERROR;



		goto checkForCatch;
            }





	    PUSH_OBJECT(valuePtr);

	    TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
	    ADJUST_PC(2);















	case INST_LOAD_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    DECACHE_STACK_INFO();
	    valuePtr = TclGetIndexedScalar(interp, opnd, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (valuePtr == NULL) {
		TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
		        Tcl_GetObjResult(interp));
		result = TCL_ERROR;
		goto checkForCatch;
            }
	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
	    ADJUST_PC(5);






	case INST_LOAD_STK:
	case INST_LOAD_SCALAR_STK:
	    objPtr = POP_OBJECT(); /* scalar / variable name */
	    DECACHE_STACK_INFO();
	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);

	    CACHE_STACK_INFO();
	    if (valuePtr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
		        Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		result = TCL_ERROR;
		goto checkForCatch;
            }

	    PUSH_OBJECT(valuePtr);



	    TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);

	    TclDecrRefCount(objPtr);

	    ADJUST_PC(1);




	case INST_LOAD_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doLoadArray;

	case INST_LOAD_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    
	    doLoadArray:




	    elemPtr = POP_OBJECT();

	    DECACHE_STACK_INFO();

	    valuePtr = TclGetElementOfIndexedArray(interp, opnd,
		    elemPtr, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (valuePtr == NULL) {
		TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
			opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
		TclDecrRefCount(elemPtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }

	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("%u \"%.30s\" => ",



		    opnd, O2S(elemPtr)),valuePtr);

	    TclDecrRefCount(elemPtr);

	    ADJUST_PC(pcAdjustment);



	case INST_LOAD_ARRAY_STK:
	    elemPtr = POP_OBJECT();




	    objPtr = POP_OBJECT();	/* array name */
	    DECACHE_STACK_INFO();
	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (valuePtr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
			O2S(objPtr), O2S(elemPtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		TclDecrRefCount(elemPtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",

		    O2S(objPtr), O2S(elemPtr)), valuePtr);




	    TclDecrRefCount(objPtr);








	    TclDecrRefCount(elemPtr);
	    ADJUST_PC(1);






	case INST_STORE_SCALAR4:

	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;


	    goto doStoreScalar;







	case INST_STORE_SCALAR1:

	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;



	  doStoreScalar:
	    valuePtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
	            TCL_LEAVE_ERR_MSG);

	    CACHE_STACK_INFO();



	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
			opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }


	    PUSH_OBJECT(value2Ptr);


	    TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
		    opnd, O2S(valuePtr)), value2Ptr);


	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(pcAdjustment);

	case INST_STORE_STK:
	case INST_STORE_SCALAR_STK:
	    valuePtr = POP_OBJECT();
	    objPtr = POP_OBJECT(); /* scalar / variable name */
	    DECACHE_STACK_INFO();

	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();


	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
		        O2S(objPtr), O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }



	    PUSH_OBJECT(value2Ptr);




	    TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",

		    O2S(objPtr), O2S(valuePtr)), value2Ptr);






	    TclDecrRefCount(objPtr);





	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(1);





	case INST_STORE_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;

	    goto doStoreArray;

	case INST_STORE_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;

	    
	    doStoreArray:
	    valuePtr = POP_OBJECT();

	    elemPtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
		    elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
			opnd, O2S(elemPtr), O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(elemPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
		    opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
	    TclDecrRefCount(elemPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(pcAdjustment);

	case INST_STORE_ARRAY_STK:
	    valuePtr = POP_OBJECT();
	    elemPtr = POP_OBJECT();
	    objPtr = POP_OBJECT();	/* array name */
	    DECACHE_STACK_INFO();
	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
			O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		TclDecrRefCount(elemPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }

	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
		    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
		    value2Ptr);
	    TclDecrRefCount(objPtr);
	    TclDecrRefCount(elemPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(1);

	    /*
	     * START APPEND INSTRUCTIONS
	     */

	case INST_APPEND_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;


	    goto doAppendScalar;

	case INST_APPEND_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;

	  doAppendScalar:
	    valuePtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
	            TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
			opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
		    opnd, O2S(valuePtr)), value2Ptr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(pcAdjustment);

	case INST_APPEND_STK:
	case INST_APPEND_ARRAY_STK:
	    valuePtr = POP_OBJECT(); /* value to append */
	    if (*pc == INST_APPEND_ARRAY_STK) {
		elemPtr = POP_OBJECT();
	    } else {
		elemPtr = NULL;
	    }
	    objPtr = POP_OBJECT(); /* scalar name */

	    DECACHE_STACK_INFO();
	    value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,

		    TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		if (elemPtr) {
		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <-+ \"%.30s\" => ERROR: ",
			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		    TclDecrRefCount(elemPtr);
		} else {
		    TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ",
			    O2S(objPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		}

		TclDecrRefCount(objPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;

		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    if (elemPtr) {
		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <-+ \"%.30s\" => ",
			O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			value2Ptr);
		TclDecrRefCount(elemPtr);
	    } else {
		TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ",
			O2S(objPtr), O2S(valuePtr)), value2Ptr);
	    }
	    TclDecrRefCount(objPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(1);

	case INST_APPEND_ARRAY4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;

	    goto doAppendArray;

	case INST_APPEND_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;


	    doAppendArray:
	    valuePtr = POP_OBJECT();
	    elemPtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
		    elemPtr, valuePtr, TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ",
			opnd, O2S(elemPtr), O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(elemPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ",
		    opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
	    TclDecrRefCount(elemPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(pcAdjustment);

	    /*
	     * END APPEND INSTRUCTIONS
	     */

	case INST_LIST:
	    /*
	     * Pop the opnd (objc) top stack elements into a new list obj
	     * and then decrement their ref counts. 
	     */

	    opnd = TclGetUInt4AtPtr(pc+1);
	    valuePtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
	    for (i = 0; i < opnd; i++) {
		objPtr = POP_OBJECT();
		TclDecrRefCount(objPtr);
	    }
	    PUSH_OBJECT(valuePtr);
	    TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
	    ADJUST_PC(5);

	    /*
	     * START LAPPEND INSTRUCTIONS
	     */

	case INST_LAPPEND_SCALAR4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doLappendScalar;

	case INST_LAPPEND_SCALAR1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    pcAdjustment = 2;

	  doLappendScalar:
	    valuePtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
	            TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
			opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
		    opnd, O2S(valuePtr)), value2Ptr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(pcAdjustment);

	case INST_LAPPEND_STK:
	case INST_LAPPEND_ARRAY_STK:
	{
	    /*
	     * This compile function for this should be refactored
	     * to make better use of existing LOAD/STORE instructions.



	     */
	    Tcl_Obj *newValuePtr;
	    int createdNewObj = 0;

	    value2Ptr = POP_OBJECT(); /* value to append */
	    if (*pc == INST_LAPPEND_ARRAY_STK) {
		elemPtr = POP_OBJECT();
	    } else {
		elemPtr = NULL;
	    }
	    objPtr = POP_OBJECT(); /* scalar name */

	    DECACHE_STACK_INFO();
	    /*
	     * Currently value of the list.
	     * 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.
	     */
	    valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
		    TCL_TRACE_READS);
	    CACHE_STACK_INFO();
	    if (valuePtr == NULL) {
		TclNewObj(valuePtr);
		createdNewObj = 1;
	    } else if (Tcl_IsShared(valuePtr)) {
		valuePtr = Tcl_DuplicateObj(valuePtr);
		createdNewObj = 1;
	    }

	    DECACHE_STACK_INFO();
	    result = Tcl_ListObjAppendElement(interp, valuePtr, value2Ptr);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		if (elemPtr) {
		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		    TclDecrRefCount(elemPtr);
		} else {
		    TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ",
			    O2S(objPtr), O2S(value2Ptr)),
			    Tcl_GetObjResult(interp));
		}
		TclDecrRefCount(objPtr);
		TclDecrRefCount(value2Ptr);
		if (createdNewObj) {
		    TclDecrRefCount(valuePtr);
		}
		result = TCL_ERROR;
		goto checkForCatch;
	    }

	    DECACHE_STACK_INFO();
	    newValuePtr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (newValuePtr == NULL) {
		if (elemPtr) {
		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		    TclDecrRefCount(elemPtr);
		} else {
		    TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ERROR: ",
			    O2S(objPtr), O2S(value2Ptr)),
			    Tcl_GetObjResult(interp));
		}
		TclDecrRefCount(objPtr);
		TclDecrRefCount(value2Ptr);
		if (createdNewObj) {
		    TclDecrRefCount(valuePtr);
		}
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(newValuePtr);
	    if (elemPtr) {
		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
			O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			value2Ptr);
		TclDecrRefCount(elemPtr);
	    } else {
		TRACE_WITH_OBJ(("\"%.30s\" <-+ \"%.30s\" => ",
			O2S(objPtr), O2S(valuePtr)), value2Ptr);
	    }
	    TclDecrRefCount(objPtr);
	    TclDecrRefCount(value2Ptr);
	    ADJUST_PC(1);



	}




	case INST_LAPPEND_ARRAY4:



	    opnd = TclGetUInt4AtPtr(pc+1);

	    pcAdjustment = 5;








	    goto doLappendArray;

	case INST_LAPPEND_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);


	    pcAdjustment = 2;


	    doLappendArray:
	    valuePtr = POP_OBJECT();
	    elemPtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
		    elemPtr, valuePtr,
		    TCL_LEAVE_ERR_MSG|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ERROR: ",
			opnd, O2S(elemPtr), O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(elemPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u \"%.30s\" <-+ \"%.30s\" => ",
		    opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
	    TclDecrRefCount(elemPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(pcAdjustment);





	    /*

	     * END (L)APPEND INSTRUCTIONS




	     */

	case INST_INCR_SCALAR1:




	    opnd = TclGetUInt1AtPtr(pc+1);
	    valuePtr = POP_OBJECT();
	    if (valuePtr->typePtr == &tclIntType) {
		i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
		if (result != TCL_OK) {
		    TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
		            opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
		    TclDecrRefCount(valuePtr);
		    goto checkForCatch;
		}
		FORCE_LONG(valuePtr, i, w);
	    }
	    DECACHE_STACK_INFO();
	    value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(2);

	case INST_INCR_SCALAR_STK:


	case INST_INCR_STK:
	    valuePtr = POP_OBJECT();
	    objPtr = POP_OBJECT(); /* scalar name */
	    if (valuePtr->typePtr == &tclIntType) {
		i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);

		if (result != TCL_OK) {
		    TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
		            O2S(objPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		    TclDecrRefCount(objPtr);
		    TclDecrRefCount(valuePtr);
		    goto checkForCatch;
		}
		FORCE_LONG(valuePtr, i, w);
	    }
	    DECACHE_STACK_INFO();
	    value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
		        O2S(objPtr), i), Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
		    value2Ptr);
	    TclDecrRefCount(objPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(1);

	case INST_INCR_ARRAY1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    valuePtr = POP_OBJECT();
	    elemPtr = POP_OBJECT();
	    if (valuePtr->typePtr == &tclIntType) {
		i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
#endif /* TCL_WIDE_INT_IS_LONG */

	    } else {
		REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
		if (result != TCL_OK) {

		    TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
			    opnd, O2S(elemPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		    TclDecrRefCount(elemPtr);
		    TclDecrRefCount(valuePtr);
		    goto checkForCatch;
		}
		FORCE_LONG(valuePtr, i, w);
	    }
	    DECACHE_STACK_INFO();
	    value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
		    elemPtr, i);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
			opnd, O2S(elemPtr), i),


			Tcl_GetObjResult(interp));





		TclDecrRefCount(elemPtr);

		TclDecrRefCount(valuePtr);

		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",

		    opnd, O2S(elemPtr), i), value2Ptr);

	    TclDecrRefCount(elemPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(2);
	    
	case INST_INCR_ARRAY_STK:
	    valuePtr = POP_OBJECT();
	    elemPtr = POP_OBJECT();
	    objPtr = POP_OBJECT();	/* array name */
	    if (valuePtr->typePtr == &tclIntType) {
		i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
		if (result != TCL_OK) {
		    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
			    O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
			    Tcl_GetObjResult(interp));
		    TclDecrRefCount(objPtr);
		    TclDecrRefCount(elemPtr);
		    TclDecrRefCount(valuePtr);

		    goto checkForCatch;
		}
		FORCE_LONG(valuePtr, i, w);
	    }
	    DECACHE_STACK_INFO();
	    value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
			O2S(objPtr), O2S(elemPtr), i),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		TclDecrRefCount(elemPtr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
		    O2S(objPtr), O2S(elemPtr), i), value2Ptr);
	    TclDecrRefCount(objPtr);
	    TclDecrRefCount(elemPtr);
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(1);
	    
	case INST_INCR_SCALAR1_IMM:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    i = TclGetInt1AtPtr(pc+2);

	    DECACHE_STACK_INFO();










	    value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
			Tcl_GetObjResult(interp));
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
	    ADJUST_PC(3);

	case INST_INCR_SCALAR_STK_IMM:
	case INST_INCR_STK_IMM:

	    objPtr = POP_OBJECT(); /* variable name */
	    i = TclGetInt1AtPtr(pc+1);
	    DECACHE_STACK_INFO();

	    value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
		        O2S(objPtr), i), Tcl_GetObjResult(interp));
		result = TCL_ERROR;
		TclDecrRefCount(objPtr);
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),


		    value2Ptr);
	    TclDecrRefCount(objPtr);

	    ADJUST_PC(2);

	case INST_INCR_ARRAY1_IMM:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    i = TclGetInt1AtPtr(pc+2);
	    elemPtr = POP_OBJECT();
	    DECACHE_STACK_INFO();
	    value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
		    elemPtr, i);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
			opnd, O2S(elemPtr), i),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(elemPtr);
		result = TCL_ERROR;
		goto checkForCatch;

	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
		    opnd, O2S(elemPtr), i), value2Ptr);
	    TclDecrRefCount(elemPtr);
	    ADJUST_PC(3);
	    
	case INST_INCR_ARRAY_STK_IMM:
	    i = TclGetInt1AtPtr(pc+1);
	    elemPtr = POP_OBJECT();
	    objPtr = POP_OBJECT();	/* array name */
	    DECACHE_STACK_INFO();
	    value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
		    TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (value2Ptr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
			O2S(objPtr), O2S(elemPtr), i),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(objPtr);
		TclDecrRefCount(elemPtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }
	    PUSH_OBJECT(value2Ptr);
	    TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",

		    O2S(objPtr), O2S(elemPtr), i), value2Ptr);
	    TclDecrRefCount(objPtr);
	    TclDecrRefCount(elemPtr);

	    ADJUST_PC(2);





	    /*
	     * END INCR INSTRUCTIONS

	     */


	case INST_JUMP1:
#ifdef TCL_COMPILE_DEBUG
	    opnd = TclGetInt1AtPtr(pc+1);
	    TRACE(("%d => new pc %u\n", opnd,
		   (unsigned int)(pc + opnd - codePtr->codeStart)));
	    pc += opnd;
#else
	    pc += TclGetInt1AtPtr(pc+1);
#endif /* TCL_COMPILE_DEBUG */
	    continue;

	case INST_JUMP4:
	    opnd = TclGetInt4AtPtr(pc+1);
	    TRACE(("%d => new pc %u\n", opnd,
		   (unsigned int)(pc + opnd - codePtr->codeStart)));

	    ADJUST_PC(opnd);





	case INST_JUMP_TRUE4:
	    opnd = TclGetInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doJumpTrue;






	case INST_JUMP_TRUE1:
	    opnd = TclGetInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    
	    doJumpTrue:
	    {
		int b;
		
		valuePtr = POP_OBJECT();
		if (valuePtr->typePtr == &tclIntType) {
		    b = (valuePtr->internalRep.longValue != 0);
		} else if (valuePtr->typePtr == &tclDoubleType) {
		    b = (valuePtr->internalRep.doubleValue != 0.0);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (valuePtr->typePtr == &tclWideIntType) {
		    b = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
		} else {
		    result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
		    if (result != TCL_OK) {
			TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
				Tcl_GetObjResult(interp));
			TclDecrRefCount(valuePtr);
			goto checkForCatch;
		    }
		}



		if (b) {

		    TRACE(("%d => %.20s true, new pc %u\n",
			    opnd, O2S(valuePtr),
		            (unsigned int)(pc+opnd - codePtr->codeStart)));
		    TclDecrRefCount(valuePtr);
		    ADJUST_PC(opnd);
		} else {
		    TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
		    TclDecrRefCount(valuePtr);
		    ADJUST_PC(pcAdjustment);
		}
	    }
	    
	case INST_JUMP_FALSE4:
	    opnd = TclGetInt4AtPtr(pc+1);
	    pcAdjustment = 5;
	    goto doJumpFalse;

	case INST_JUMP_FALSE1:
	    opnd = TclGetInt1AtPtr(pc+1);
	    pcAdjustment = 2;
	    
	    doJumpFalse:
	    {
		int b;
		
		valuePtr = POP_OBJECT();
		if (valuePtr->typePtr == &tclIntType) {
		    b = (valuePtr->internalRep.longValue != 0);
		} else if (valuePtr->typePtr == &tclDoubleType) {
		    b = (valuePtr->internalRep.doubleValue != 0.0);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (valuePtr->typePtr == &tclWideIntType) {
		    b = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
		} else {
		    result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
		    if (result != TCL_OK) {
			TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
				Tcl_GetObjResult(interp));
			TclDecrRefCount(valuePtr);
			goto checkForCatch;
		    }

		}
		if (b) {
		    TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
		    TclDecrRefCount(valuePtr);
		    ADJUST_PC(pcAdjustment);
		} else {

		    TRACE(("%d => %.20s false, new pc %u\n",
			   opnd, O2S(valuePtr),
			   (unsigned int)(pc + opnd - codePtr->codeStart)));
		    TclDecrRefCount(valuePtr);

		    ADJUST_PC(opnd);
		}

	    }
	    
	case INST_LOR:
	case INST_LAND:
	    {
		/*
		 * Operands must be boolean or numeric. No int->double
		 * conversions are performed.
		 */
		
		int i1, i2;
		int iResult;
		char *s;
		Tcl_ObjType *t1Ptr, *t2Ptr;

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT();
		t1Ptr = valuePtr->typePtr;
		t2Ptr = value2Ptr->typePtr;

		if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
		    i1 = (valuePtr->internalRep.longValue != 0);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (t1Ptr == &tclWideIntType) {
		    i1 = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
		} else if (t1Ptr == &tclDoubleType) {
		    i1 = (valuePtr->internalRep.doubleValue != 0.0);
		} else {
		    s = Tcl_GetStringFromObj(valuePtr, &length);
		    if (TclLooksLikeInt(s, length)) {
#ifdef TCL_WIDE_INT_IS_LONG
			result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
				valuePtr, &i);
			i1 = (i != 0);
#else /* !TCL_WIDE_INT_IS_LONG */
			GET_WIDE_OR_INT(result, valuePtr, i, w);
			if (valuePtr->typePtr == &tclIntType) {
			    i1 = (i != 0);
			} else {
			    i1 = (w != W0);
			}
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
				valuePtr, &i1);
			i1 = (i1 != 0);
		    }
		    if (result != TCL_OK) {
			TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
			        O2S(valuePtr),
			        (t1Ptr? t1Ptr->name : "null")));
			IllegalExprOperandType(interp, pc, valuePtr);
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
		}
		
		if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
		    i2 = (value2Ptr->internalRep.longValue != 0);
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (t2Ptr == &tclWideIntType) {
		    i2 = (value2Ptr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
		} else if (t2Ptr == &tclDoubleType) {
		    i2 = (value2Ptr->internalRep.doubleValue != 0.0);
		} else {
		    s = Tcl_GetStringFromObj(value2Ptr, &length);
		    if (TclLooksLikeInt(s, length)) {
#ifdef TCL_WIDE_INT_IS_LONG
			result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
				value2Ptr, &i);
			i2 = (i != 0);
#else /* !TCL_WIDE_INT_IS_LONG */
			GET_WIDE_OR_INT(result, value2Ptr, i, w);
			if (value2Ptr->typePtr == &tclIntType) {
			    i2 = (i != 0);
			} else {
			    i2 = (w != W0);
			}
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
				value2Ptr, &i2);
		    }
		    if (result != TCL_OK) {
			TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
			        O2S(value2Ptr),
			        (t2Ptr? t2Ptr->name : "null")));
			IllegalExprOperandType(interp, pc, value2Ptr);
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
		}

		/*
		 * Reuse the valuePtr object already on stack if possible.
		 */

		if (*pc == INST_LOR) {
		    iResult = (i1 || i2);
		} else {
		    iResult = (i1 && i2);
		}
		if (Tcl_IsShared(valuePtr)) {
		    PUSH_OBJECT(Tcl_NewLongObj(iResult));
		    TRACE(("%.20s %.20s => %d\n",
			   O2S(valuePtr), O2S(value2Ptr), iResult));
		    TclDecrRefCount(valuePtr);
		} else {	/* reuse the valuePtr object */
		    TRACE(("%.20s %.20s => %d\n", 
			   O2S(valuePtr), O2S(value2Ptr), iResult));
		    Tcl_SetLongObj(valuePtr, iResult);
		    ++stackTop; /* valuePtr now on stk top has right r.c. */

		}

		TclDecrRefCount(value2Ptr);




	    }





	    ADJUST_PC(1);





	case INST_LIST_LENGTH:
	    valuePtr = POP_OBJECT();

	    result = Tcl_ListObjLength(interp, valuePtr, &length);
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(valuePtr);
		goto checkForCatch;
	    }
	    PUSH_OBJECT(Tcl_NewIntObj(length));
	    TRACE(("%.20s => %d\n", O2S(valuePtr), length));
	    TclDecrRefCount(valuePtr);
	    ADJUST_PC(1);
	    
	case INST_LIST_INDEX:
	    /*** lindex with objc == 3 ***/
		
	    /*
	     * Pop the two operands
	     */
	    value2Ptr = POP_OBJECT();
	    valuePtr  = POP_OBJECT();

	    /*
	     * Extract the desired list element
	     */
	    objPtr = TclLindexList(interp, valuePtr, value2Ptr);
	    if (objPtr == NULL) {
		TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
			O2S(valuePtr), O2S(value2Ptr)),
			Tcl_GetObjResult(interp));
		TclDecrRefCount(value2Ptr);
		TclDecrRefCount(valuePtr);
		result = TCL_ERROR;
		goto checkForCatch;
	    }

	    /*
	     * Stash the list element on the stack
	     */
	    PUSH_OBJECT(objPtr);
	    TRACE(("%.20s %.20s => %s\n",
		    O2S(valuePtr), O2S(value2Ptr), O2S(objPtr)));
	    TclDecrRefCount(valuePtr);
	    TclDecrRefCount(value2Ptr);
	    TclDecrRefCount(objPtr);
	    ADJUST_PC(1);

	case INST_LIST_INDEX_MULTI:
	    {
		/*
		 * 'lindex' with multiple index args:
		 *
		 * Determine the count of index args.
		 */

		int numIdx;

		opnd = TclGetUInt4AtPtr(pc+1);
		numIdx = opnd-1;

		/*
		 * Do the 'lindex' operation.
		 */
		objPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
			numIdx, stackPtr + stackTop - numIdx + 1);

		/* 
		 * Clean up ref counts
		 */
		for (i=0 ; i<=numIdx ; i++) {
		    /*
		     * Watch out for multiple references in macros!
		     */

		    valuePtr = POP_OBJECT();
		    TclDecrRefCount(valuePtr);
		}

		/*
		 * Check for errors
		 */
		if (objPtr == NULL) {
		    TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
			    Tcl_GetObjResult(interp));
		    result = TCL_ERROR;
		    goto checkForCatch;
		}

		/*
		 * Set result
		 */
		PUSH_OBJECT(objPtr);
		TRACE(("%d => %s\n", opnd, O2S(objPtr)));
		TclDecrRefCount(objPtr);

	    }
	    ADJUST_PC(5);

	case INST_LSET_FLAT:
	    {
		/*
		 * Lset with 3, 5, or more args.  Get the number
		 * of index args.
		 */
		int numIdx;

		opnd = TclGetUInt4AtPtr( pc + 1 );
		numIdx = opnd - 2;

		/*
		 * Get the old value of variable, and remove the stack ref.
		 * This is safe because the variable still references the
		 * object; the ref count will never go zero here.
		 */
		value2Ptr = POP_OBJECT();
		TclDecrRefCount(value2Ptr);

		/*
		 * Get the new element value.
		 */
		valuePtr = POP_OBJECT();

		/*
		 * Compute the new variable value
		 */
		objPtr = TclLsetFlat(interp, value2Ptr, numIdx,
			stackPtr + stackTop - numIdx + 1, valuePtr);
		TclDecrRefCount(valuePtr);

		/* 
		 * Clean up ref counts
		 */
		for (i=0 ; i<numIdx ; i++) {
		    /*
		     * Watch out for multiple references in macros!
		     */

		    valuePtr = POP_OBJECT();
		    TclDecrRefCount(valuePtr);
		}

		/*
		 * Check for errors
		 */
		if (objPtr == NULL) {
		    TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
			    Tcl_GetObjResult(interp));
		    result = TCL_ERROR;
		    goto checkForCatch;
		}

		/*
		 * Set result
		 */
		PUSH_OBJECT(objPtr);
		TRACE(("%d => %s\n", opnd, O2S(objPtr)));
		TclDecrRefCount(objPtr);

	    }
	    ADJUST_PC(5);

	case INST_LSET_LIST:
	    /*
	     * 'lset' with 4 args.
	     *
	     * Get the old value of variable, and remove the stack ref.
	     * This is safe because the variable still references the
	     * object; the ref count will never go zero here.
	     */
	    objPtr = POP_OBJECT();
	    TclDecrRefCount(objPtr);

	    /*
	     * Get the new element value, and the index list
	     */
	    valuePtr = POP_OBJECT();
	    value2Ptr = POP_OBJECT();

	    /*
	     * Compute the new variable value
	     */
	    objPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
	    TclDecrRefCount(valuePtr);
	    TclDecrRefCount(value2Ptr);

	    /*
	     * Check for errors
	     */
	    if (objPtr == NULL) {
		TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
			Tcl_GetObjResult(interp));
		result = TCL_ERROR;
		goto checkForCatch;
	    }

	    /*
	     * Set result
	     */
	    PUSH_OBJECT(objPtr);
	    TRACE(("=> %s\n", O2S(objPtr)));

	    TclDecrRefCount(objPtr);

	    ADJUST_PC(1);



	case INST_STR_EQ:
	case INST_STR_NEQ:
	    {
		/*
		 * String (in)equality check
		 */
		int iResult;

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT();

		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);
		    }
		}

		PUSH_OBJECT(Tcl_NewIntObj(iResult));
		TRACE(("%.20s %.20s => %d\n",
			O2S(valuePtr), O2S(value2Ptr), iResult));

		TclDecrRefCount(valuePtr);


		TclDecrRefCount(value2Ptr);











	    }


	    ADJUST_PC(1);


	case INST_STR_CMP:
	    {
		/*
		 * String compare
		 */
		CONST char *s1, *s2;
		int s1len, s2len, iResult;

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT();

		/*
		 * The comparison function should compare up to the
		 * minimum byte length only.
		 */
		if (valuePtr == value2Ptr) {
		    /*
		     * In the pure equality case, set lengths too for
		     * the checks below (or we could goto beyond it).
		     */
		    iResult = s1len = s2len = 0;
		} else if ((valuePtr->typePtr == &tclByteArrayType) &&
			(value2Ptr->typePtr == &tclByteArrayType)) {
		    s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
		    s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
		    iResult = memcmp(s1, s2,
			    (size_t) ((s1len < s2len) ? s1len : s2len));
		} else if (((valuePtr->typePtr == &tclStringType)
			&& (value2Ptr->typePtr == &tclStringType))) {
		    /*
		     * Do a unicode-specific comparison if both of the args
		     * are of String type.  In benchmark testing this proved
		     * the most efficient check between the unicode and
		     * string comparison operations.
		     */
		    Tcl_UniChar *uni1, *uni2;
		    uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len);
		    uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
		    iResult = TclUniCharNcmp(uni1, uni2,
			    (unsigned) ((s1len < s2len) ? s1len : s2len));
		} else {
		    /*
		     * We can't do a simple memcmp in order to handle the
		     * special Tcl \xC0\x80 null encoding for utf-8.
		     */
		    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
		    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
		    iResult = TclpUtfNcmp2(s1, s2,
			    (size_t) ((s1len < s2len) ? s1len : s2len));
		}

		/*
		 * Make sure only -1,0,1 is returned
		 */
		if (iResult == 0) {
		    iResult = s1len - s2len;
		}
		if (iResult < 0) {
		    iResult = -1;
		} else if (iResult > 0) {
		    iResult = 1;
		}

		PUSH_OBJECT(Tcl_NewIntObj(iResult));
		TRACE(("%.20s %.20s => %d\n",
			O2S(valuePtr), O2S(value2Ptr), iResult));
		TclDecrRefCount(valuePtr);
		TclDecrRefCount(value2Ptr);
	    }
	    ADJUST_PC(1);

       case INST_STR_LEN:
	    {
		int length1;
		 
		valuePtr = POP_OBJECT();

		if (valuePtr->typePtr == &tclByteArrayType) {
		    (void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
		} else {
		    length1 = Tcl_GetCharLength(valuePtr);
		}
		PUSH_OBJECT(Tcl_NewIntObj(length1));
		TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
		TclDecrRefCount(valuePtr);

	    }
	    ADJUST_PC(1);
	    
       case INST_STR_INDEX:
	    {
		/*
		 * String compare
		 */
		int index;
		bytes = NULL; /* lint */

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT();

		/*
		 * 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) {
		    TclDecrRefCount(value2Ptr);
		    TclDecrRefCount(valuePtr);
		    goto checkForCatch;
		}

		if ((index >= 0) && (index < length)) {
		    if (valuePtr->typePtr == &tclByteArrayType) {
			objPtr = Tcl_NewByteArrayObj((unsigned char *)
				(&bytes[index]), 1);
		    } else {
			char buf[TCL_UTF_MAX];
			Tcl_UniChar ch;

			ch = Tcl_GetUniChar(valuePtr, index);
			/*
			 * This could be:
			 * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
			 * but creating the object as a string seems to be
			 * faster in practical use.
			 */
			length = Tcl_UniCharToUtf(ch, buf);
			objPtr = Tcl_NewStringObj(buf, length);
		    }
		} else {
		    TclNewObj(objPtr);
		}

		PUSH_OBJECT(objPtr);
		TRACE(("%.20s %.20s => %s\n",
			O2S(valuePtr), O2S(value2Ptr), O2S(objPtr)));
		TclDecrRefCount(valuePtr);
		TclDecrRefCount(value2Ptr);

	    }
	    ADJUST_PC(1);

	case INST_STR_MATCH:
	    {
		int nocase, match;

		nocase    = TclGetInt1AtPtr(pc+1);
		valuePtr  = POP_OBJECT();	/* String */
		value2Ptr = POP_OBJECT();	/* Pattern */

		/*
		 * Check that at least one of the objects
		 * is Unicode before promoting both.
		 */
		if ((valuePtr->typePtr == &tclStringType)
			|| (value2Ptr->typePtr == &tclStringType)) {
		    match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr),
			    Tcl_GetUnicode(value2Ptr), nocase);
		} else {
		    match = Tcl_StringCaseMatch(TclGetString(valuePtr),
			    TclGetString(value2Ptr), nocase);
		}

		/*
		 * Reuse value2Ptr object already on stack if possible.

		 */

		TRACE(("%.20s %.20s => %d\n",
			O2S(valuePtr), O2S(value2Ptr), match));
		TclDecrRefCount(valuePtr);
		if (Tcl_IsShared(value2Ptr)) {
		    PUSH_OBJECT(Tcl_NewIntObj(match));
		    TclDecrRefCount(value2Ptr);

		} else {	/* reuse the valuePtr object */
		    Tcl_SetIntObj(value2Ptr, match);
		    ++stackTop; /* valuePtr now on stk top has right r.c. */

		}
	    }
	    /*
	     * Adjustment is 2 due to the nocase byte
	     */
	    ADJUST_PC(2);

	case INST_EQ:
	case INST_NEQ:
	case INST_LT:
	case INST_GT:
	case INST_LE:
	case INST_GE:
	    {
		/*
		 * Any type is allowed but the two operands must have the
	         * same type. We will compute value op value2.
		 */

		Tcl_ObjType *t1Ptr, *t2Ptr;
		char *s1 = NULL;	/* Init. avoids compiler warning. */
		char *s2 = NULL;	/* Init. avoids compiler warning. */
		long i2 = 0;		/* Init. avoids compiler warning. */
		double d1 = 0.0;	/* Init. avoids compiler warning. */
		double d2 = 0.0;	/* Init. avoids compiler warning. */
		long iResult = 0;	/* Init. avoids compiler warning. */

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT();

		if (valuePtr == value2Ptr) {
		    /*
		     * Optimize the equal object case.
		     */
		    switch (*pc) {
			case INST_EQ:
			case INST_LE:
			case INST_GE:
			    iResult = 1;
			    break;
			case INST_NEQ:
			case INST_LT:
			case INST_GT:
			    iResult = 0;
			    break;
		    }
		    goto foundResult;
		}

		t1Ptr = valuePtr->typePtr;
		t2Ptr = value2Ptr->typePtr;

		/*
		 * We only want to coerce numeric validation if
		 * neither type is NULL.  A NULL type means the arg is
		 * essentially an empty object ("", {} or [list]).
		 */
		if (!(     (!t1Ptr && !valuePtr->bytes)
			|| (valuePtr->bytes && !valuePtr->length)
			|| (!t2Ptr && !value2Ptr->bytes)
			|| (value2Ptr->bytes && !value2Ptr->length))) {
		    if (!IS_NUMERIC_TYPE(t1Ptr)) {
			s1 = Tcl_GetStringFromObj(valuePtr, &length);
			if (TclLooksLikeInt(s1, length)) {
			    GET_WIDE_OR_INT(iResult, valuePtr, i, w);
			} else {
			    (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				    valuePtr, &d1);
			}
			t1Ptr = valuePtr->typePtr;
		    }
		    if (!IS_NUMERIC_TYPE(t2Ptr)) {
			s2 = Tcl_GetStringFromObj(value2Ptr, &length);
			if (TclLooksLikeInt(s2, length)) {
			    GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
			} else {
			    (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				    value2Ptr, &d2);
			}
			t2Ptr = value2Ptr->typePtr;
		    }
		}
		if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
		    /*
		     * One operand is not numeric. Compare as strings.
		     * NOTE: strcmp is not correct for \x00 < \x01, but
		     * that is unlikely to occur here.  We could use the
		     * TclUtfNCmp2 to handle this.
		     */
		    int s1len, s2len;
		    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
		    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
		    switch (*pc) {
		    case INST_EQ:
			if (s1len == s2len) {
			    iResult = (strcmp(s1, s2) == 0);
			} else {
			    iResult = 0;
			}
			break;
		    case INST_NEQ:
			if (s1len == s2len) {
			    iResult = (strcmp(s1, s2) != 0);
			} else {
			    iResult = 1;
			}
			break;
		    case INST_LT:
			iResult = (strcmp(s1, s2) < 0);
			break;
		    case INST_GT:
			iResult = (strcmp(s1, s2) > 0);
			break;
		    case INST_LE:
			iResult = (strcmp(s1, s2) <= 0);
			break;
		    case INST_GE:
			iResult = (strcmp(s1, s2) >= 0);
			break;
		    }
		} else if ((t1Ptr == &tclDoubleType)
		        || (t2Ptr == &tclDoubleType)) {
		    /*
		     * Compare as doubles.
		     */
		    if (t1Ptr == &tclDoubleType) {
			d1 = valuePtr->internalRep.doubleValue;
			GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
		    } else {	/* t1Ptr is integer, t2Ptr is double */
			GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
			d2 = value2Ptr->internalRep.doubleValue;
		    }
		    switch (*pc) {
		    case INST_EQ:
			iResult = d1 == d2;
			break;
		    case INST_NEQ:
			iResult = d1 != d2;
			break;
		    case INST_LT:
			iResult = d1 < d2;
			break;
		    case INST_GT:
			iResult = d1 > d2;
			break;
		    case INST_LE:
			iResult = d1 <= d2;
			break;
		    case INST_GE:
			iResult = d1 >= d2;
			break;
		    }
#ifndef TCL_WIDE_INT_IS_LONG
		} else if ((t1Ptr == &tclWideIntType)
		        || (t2Ptr == &tclWideIntType)) {
		    Tcl_WideInt w2;
		    /*
		     * Compare as wide ints (neither are doubles)
		     */
		    if (t1Ptr == &tclIntType) {
			w  = Tcl_LongAsWide(valuePtr->internalRep.longValue);
			w2 = value2Ptr->internalRep.wideValue;
		    } else if (t2Ptr == &tclIntType) {
			w  = valuePtr->internalRep.wideValue;
			w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
		    } else {
			w  = valuePtr->internalRep.wideValue;
			w2 = value2Ptr->internalRep.wideValue;
		    }
		    switch (*pc) {
		    case INST_EQ:
			iResult = w == w2;
			break;
		    case INST_NEQ:
			iResult = w != w2;
			break;
		    case INST_LT:
			iResult = w < w2;
			break;
		    case INST_GT:
			iResult = w > w2;
			break;
		    case INST_LE:
			iResult = w <= w2;
			break;
		    case INST_GE:
			iResult = w >= w2;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		} else {
		    /*
		     * Compare as ints.
		     */
		    i  = valuePtr->internalRep.longValue;
		    i2 = value2Ptr->internalRep.longValue;
		    switch (*pc) {
		    case INST_EQ:
			iResult = i == i2;
			break;
		    case INST_NEQ:
			iResult = i != i2;
			break;
		    case INST_LT:
			iResult = i < i2;
			break;
		    case INST_GT:
			iResult = i > i2;
			break;
		    case INST_LE:
			iResult = i <= i2;
			break;
		    case INST_GE:
			iResult = i >= i2;
			break;
		    }
		}

		/*
		 * Reuse the valuePtr object already on stack if possible.
		 */
		foundResult:
		TRACE(("%.20s %.20s => %ld\n",
		       O2S(valuePtr), O2S(value2Ptr), iResult));


		if (Tcl_IsShared(valuePtr)) {

		    PUSH_OBJECT(Tcl_NewLongObj(iResult));
		    TclDecrRefCount(valuePtr);


		} else {	/* reuse the valuePtr object */
		    Tcl_SetLongObj(valuePtr, iResult);
		    ++stackTop; /* valuePtr now on stk top has right r.c. */






		}
		TclDecrRefCount(value2Ptr);



	    }
	    ADJUST_PC(1);

	case INST_MOD:
	case INST_LSHIFT:
	case INST_RSHIFT:
	case INST_BITOR:
	case INST_BITXOR:
	case INST_BITAND:
	    {
		/*
		 * Only integers are allowed. We compute value op value2.
		 */

		long i2 = 0, rem, negative;
		long iResult = 0; /* Init. avoids compiler warning. */
#ifndef TCL_WIDE_INT_IS_LONG
		Tcl_WideInt w2, wResult = W0;
		int doWide = 0;
#endif /* TCL_WIDE_INT_IS_LONG */

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT(); 
		if (valuePtr->typePtr == &tclIntType) {
		    i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (valuePtr->typePtr == &tclWideIntType) {
		    w = valuePtr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
		} else {	/* try to convert to int */
		    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
		    if (result != TCL_OK) {
			TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
			      O2S(valuePtr), O2S(value2Ptr),
			      (valuePtr->typePtr?
				   valuePtr->typePtr->name : "null")));
			IllegalExprOperandType(interp, pc, valuePtr);
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
		}
		if (value2Ptr->typePtr == &tclIntType) {
		    i2 = value2Ptr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (value2Ptr->typePtr == &tclWideIntType) {
		    w2 = value2Ptr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
		} else {
		    REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
		    if (result != TCL_OK) {
			TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
			      O2S(valuePtr), O2S(value2Ptr),
			      (value2Ptr->typePtr?
				   value2Ptr->typePtr->name : "null")));
			IllegalExprOperandType(interp, pc, value2Ptr);
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
		}

		switch (*pc) {
		case INST_MOD:
		    /*
		     * This code is tricky: C doesn't guarantee much about
		     * the quotient or remainder, but Tcl does. The
		     * remainder always has the same sign as the divisor and
		     * a smaller absolute value.
		     */
#ifdef TCL_WIDE_INT_IS_LONG
		    if (i2 == 0) {
			TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto divideByZero;
		    }
#else /* !TCL_WIDE_INT_IS_LONG */
		    if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
			if (valuePtr->typePtr == &tclIntType) {
			    LLTRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
			} else {
			    LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
			}
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto divideByZero;
		    }
		    if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
			if (valuePtr->typePtr == &tclIntType) {
			    TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
			} else {
			    LLTRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
			}
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
 			goto divideByZero;
 		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    negative = 0;
#ifndef TCL_WIDE_INT_IS_LONG
		    if (valuePtr->typePtr == &tclWideIntType
			    || value2Ptr->typePtr == &tclWideIntType) {
			Tcl_WideInt wRemainder;
			/*
			 * Promote to wide
			 */
			if (valuePtr->typePtr == &tclIntType) {
			    w = Tcl_LongAsWide(i);
			} else if (value2Ptr->typePtr == &tclIntType) {
			    w2 = Tcl_LongAsWide(i2);
			}
			if (w2 < 0) {
			    w2 = -w2;
			    w = -w;
			    negative = 1;
			}
			wRemainder  = w % w2;
			if (wRemainder < 0) {
			    wRemainder += w2;
			}
			if (negative) {
			    wRemainder = -wRemainder;
			}
			wResult = wRemainder;
			doWide = 1;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    if (i2 < 0) {
			i2 = -i2;
			i = -i;
			negative = 1;
		    }
		    rem  = i % i2;
		    if (rem < 0) {
			rem += i2;
		    }
		    if (negative) {
			rem = -rem;
		    }
		    iResult = rem;
		    break;
		case INST_LSHIFT:
#ifndef TCL_WIDE_INT_IS_LONG
		    /*
		     * Shifts are never usefully 64-bits wide!
		     */
		    FORCE_LONG(value2Ptr, i2, w2);
		    if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
			w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
			wResult = w << i2;
			doWide = 1;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    iResult = i << i2;
		    break;
		case INST_RSHIFT:
		    /*
		     * The following code is a bit tricky: it ensures that
		     * right shifts propagate the sign bit even on machines
		     * where ">>" won't do it by default.
		     */
#ifndef TCL_WIDE_INT_IS_LONG
		    /*
		     * Shifts are never usefully 64-bits wide!
		     */
		    FORCE_LONG(value2Ptr, i2, w2);
		    if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
			w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
			if (w < 0) {
			    wResult = ~((~w) >> i2);
			} else {
			    wResult = w >> i2;
			}
			doWide = 1;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    if (i < 0) {
			iResult = ~((~i) >> i2);
		    } else {
			iResult = i >> i2;
		    }
		    break;
		case INST_BITOR:
#ifndef TCL_WIDE_INT_IS_LONG
		    if (valuePtr->typePtr == &tclWideIntType
			    || value2Ptr->typePtr == &tclWideIntType) {
			/*
			 * Promote to wide
			 */
			if (valuePtr->typePtr == &tclIntType) {
			    w = Tcl_LongAsWide(i);
			} else if (value2Ptr->typePtr == &tclIntType) {
			    w2 = Tcl_LongAsWide(i2);
			}
			wResult = w | w2;
			doWide = 1;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    iResult = i | i2;
		    break;
		case INST_BITXOR:
#ifndef TCL_WIDE_INT_IS_LONG
		    if (valuePtr->typePtr == &tclWideIntType
			    || value2Ptr->typePtr == &tclWideIntType) {
			/*
			 * Promote to wide
			 */
			if (valuePtr->typePtr == &tclIntType) {
			    w = Tcl_LongAsWide(i);
			} else if (value2Ptr->typePtr == &tclIntType) {
			    w2 = Tcl_LongAsWide(i2);
			}
			wResult = w ^ w2;
			doWide = 1;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    iResult = i ^ i2;
		    break;
		case INST_BITAND:
#ifndef TCL_WIDE_INT_IS_LONG
		    if (valuePtr->typePtr == &tclWideIntType
			    || value2Ptr->typePtr == &tclWideIntType) {
			/*
			 * Promote to wide
			 */
			if (valuePtr->typePtr == &tclIntType) {
			    w = Tcl_LongAsWide(i);
			} else if (value2Ptr->typePtr == &tclIntType) {
			    w2 = Tcl_LongAsWide(i2);
			}
			wResult = w & w2;
			doWide = 1;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    iResult = i & i2;
		    break;
		}

		/*
		 * Reuse the valuePtr object already on stack if possible.
		 */
		
		if (Tcl_IsShared(valuePtr)) {
#ifndef TCL_WIDE_INT_IS_LONG
		    if (doWide) {
			PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
			LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		    } else {
#endif /* TCL_WIDE_INT_IS_LONG */
			PUSH_OBJECT(Tcl_NewLongObj(iResult));
			TRACE(("%ld %ld => %ld\n", i, i2, iResult));
#ifndef TCL_WIDE_INT_IS_LONG
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    TclDecrRefCount(valuePtr);
		} else {	/* reuse the valuePtr object */
#ifndef TCL_WIDE_INT_IS_LONG
		    if (doWide) {
			LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
			Tcl_SetWideIntObj(valuePtr, wResult);
		    } else {
#endif /* TCL_WIDE_INT_IS_LONG */
			TRACE(("%ld %ld => %ld\n", i, i2, iResult));
			Tcl_SetLongObj(valuePtr, iResult);
#ifndef TCL_WIDE_INT_IS_LONG
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		    ++stackTop; /* valuePtr now on stk top has right r.c. */
		}
		TclDecrRefCount(value2Ptr);
	    }
	    ADJUST_PC(1);

	case INST_ADD:
	case INST_SUB:
	case INST_MULT:
	case INST_DIV:
	    {
		/*
		 * Operands must be numeric and ints get converted to floats
		 * if necessary. We compute value op value2.
		 */

		Tcl_ObjType *t1Ptr, *t2Ptr;
		long i2 = 0, quot, rem;	/* Init. avoids compiler warning. */
		double d1, d2;
		long iResult = 0;	/* Init. avoids compiler warning. */
		double dResult = 0.0;	/* Init. avoids compiler warning. */
		int doDouble = 0;	/* 1 if doing floating arithmetic */
#ifndef TCL_WIDE_INT_IS_LONG
		Tcl_WideInt w2, wquot, wrem;
		Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
		int doWide = 0;		/* 1 if doing wide arithmetic. */
#endif /* TCL_WIDE_INT_IS_LONG */

		value2Ptr = POP_OBJECT();
		valuePtr  = POP_OBJECT();
		t1Ptr = valuePtr->typePtr;
		t2Ptr = value2Ptr->typePtr;
		
		if (t1Ptr == &tclIntType) {
		    i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (t1Ptr == &tclWideIntType) {
		    w = valuePtr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
		} else if ((t1Ptr == &tclDoubleType)
			&& (valuePtr->bytes == NULL)) {
		    /*
		     * We can only use the internal rep directly if there is
		     * no string rep.  Otherwise the string rep might actually
		     * look like an integer, which is preferred.
		     */

		    d1 = valuePtr->internalRep.doubleValue;
		} else {
		    char *s = Tcl_GetStringFromObj(valuePtr, &length);
		    if (TclLooksLikeInt(s, length)) {
			GET_WIDE_OR_INT(result, valuePtr, i, w);
		    } else {
			result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				valuePtr, &d1);
		    }
		    if (result != TCL_OK) {
			TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
			       s, O2S(valuePtr),
			       (valuePtr->typePtr?
				    valuePtr->typePtr->name : "null")));
			IllegalExprOperandType(interp, pc, valuePtr);
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
		    t1Ptr = valuePtr->typePtr;
		}

		if (t2Ptr == &tclIntType) {
		    i2 = value2Ptr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
		} else if (t2Ptr == &tclWideIntType) {
		    w2 = value2Ptr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
		} else if ((t2Ptr == &tclDoubleType)
			&& (value2Ptr->bytes == NULL)) {
		    /*
		     * We can only use the internal rep directly if there is
		     * no string rep.  Otherwise the string rep might actually
		     * look like an integer, which is preferred.
		     */

		    d2 = value2Ptr->internalRep.doubleValue;
		} else {
		    char *s = Tcl_GetStringFromObj(value2Ptr, &length);
		    if (TclLooksLikeInt(s, length)) {
			GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
		    } else {
			result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				value2Ptr, &d2);
		    }
		    if (result != TCL_OK) {
			TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
			       O2S(value2Ptr), s,
			       (value2Ptr->typePtr?
				    value2Ptr->typePtr->name : "null")));
			IllegalExprOperandType(interp, pc, value2Ptr);
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
		    t2Ptr = value2Ptr->typePtr;
		}

		if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
		    /*
		     * Do double arithmetic.
		     */
		    doDouble = 1;
		    if (t1Ptr == &tclIntType) {
			d1 = i;       /* promote value 1 to double */
		    } else if (t2Ptr == &tclIntType) {
			d2 = i2;      /* promote value 2 to double */
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (t1Ptr == &tclWideIntType) {
			d1 = Tcl_WideAsDouble(w);
		    } else if (t2Ptr == &tclWideIntType) {
			d2 = Tcl_WideAsDouble(w2);
#endif /* TCL_WIDE_INT_IS_LONG */
		    }
		    switch (*pc) {
		    case INST_ADD:
			dResult = d1 + d2;
			break;
		    case INST_SUB:
			dResult = d1 - d2;
			break;
		    case INST_MULT:
			dResult = d1 * d2;
			break;
		    case INST_DIV:
			if (d2 == 0.0) {
			    TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
			    TclDecrRefCount(valuePtr);
			    TclDecrRefCount(value2Ptr);
			    goto divideByZero;
			}
			dResult = d1 / d2;
			break;
		    }
		    
		    /*
		     * Check now for IEEE floating-point error.
		     */
		    
		    if (IS_NAN(dResult) || IS_INF(dResult)) {
			TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
			       O2S(valuePtr), O2S(value2Ptr)));
			TclExprFloatError(interp, dResult);
			result = TCL_ERROR;
			TclDecrRefCount(valuePtr);
			TclDecrRefCount(value2Ptr);
			goto checkForCatch;
		    }
#ifndef TCL_WIDE_INT_IS_LONG
		} else if ((t1Ptr == &tclWideIntType) ||
			(t2Ptr == &tclWideIntType)) {
		    /*
		     * Do wide integer arithmetic.
		     */
		    doWide = 1;
		    if (t1Ptr == &tclIntType) {
			w = Tcl_LongAsWide(i);
		    } else if (t2Ptr == &tclIntType) {
			w2 = Tcl_LongAsWide(i2);
		    }
		    switch (*pc) {
		    case INST_ADD:
			wResult = w + w2;
			break;
		    case INST_SUB:
			wResult = w - w2;
			break;
		    case INST_MULT:
			wResult = w * w2;
			break;
		    case INST_DIV:
			/*
			 * This code is tricky: C doesn't guarantee much
			 * about the quotient or remainder, but Tcl does.
			 * The remainder always has the same sign as the
			 * divisor and a smaller absolute value.
			 */
			if (w2 == W0) {
			    LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
			    TclDecrRefCount(valuePtr);
			    TclDecrRefCount(value2Ptr);
			    goto divideByZero;
			}
			if (w2 < 0) {
			    w2 = -w2;
			    w = -w;
			}
			wquot = w / w2;
			wrem  = w % w2;
			if (wrem < W0) {
			    wquot -= 1;
			}
			wResult = wquot;
			break;
		    }
#endif /* TCL_WIDE_INT_IS_LONG */
		} else {
		    /*
		     * Do integer arithmetic.
		     */
		    switch (*pc) {
		    case INST_ADD:
			iResult = i + i2;
			break;
		    case INST_SUB:
			iResult = i - i2;
			break;
		    case INST_MULT:
			iResult = i * i2;
			break;
		    case INST_DIV:
			/*
			 * This code is tricky: C doesn't guarantee much
			 * about the quotient or remainder, but Tcl does.
			 * The remainder always has the same sign as the
			 * divisor and a smaller absolute value.
			 */
			if (i2 == 0) {
			    TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
			    TclDecrRefCount(valuePtr);
			    TclDecrRefCount(value2Ptr);
			    goto divideByZero;
			}
			if (i2 < 0) {
			    i2 = -i2;
			    i = -i;
			}
			quot = i / i2;
			rem  = i % i2;
			if (rem < 0) {
			    quot -= 1;
			}
			iResult = quot;
			break;
		    }
		}

		/*
		 * Reuse the valuePtr object already on stack if possible.
		 */
		
		if (Tcl_IsShared(valuePtr)) {
		    if (doDouble) {
			PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
			TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (doWide) {
			PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
			LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			PUSH_OBJECT(Tcl_NewLongObj(iResult));
			TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		    } 
		    TclDecrRefCount(valuePtr);
		} else {	    /* reuse the valuePtr object */
		    if (doDouble) { /* NB: stack top is off by 1 */
			TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
			Tcl_SetDoubleObj(valuePtr, dResult);
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (doWide) {
			LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
			Tcl_SetWideIntObj(valuePtr, wResult);
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			TRACE(("%ld %ld => %ld\n", i, i2, iResult));
			Tcl_SetLongObj(valuePtr, iResult);
		    }
		    ++stackTop; /* valuePtr now on stk top has right r.c. */
		}
		TclDecrRefCount(value2Ptr);
	    }
	    ADJUST_PC(1);

	case INST_UPLUS:
	    {
	        /*
	         * Operand must be numeric.
	         */

		double d;
		Tcl_ObjType *tPtr;
		
		valuePtr = stackPtr[stackTop];
		tPtr = valuePtr->typePtr;
		if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
			|| (valuePtr->bytes != NULL))) {
		    char *s = Tcl_GetStringFromObj(valuePtr, &length);
		    if (TclLooksLikeInt(s, length)) {
			GET_WIDE_OR_INT(result, valuePtr, i, w);
		    } else {
			result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				valuePtr, &d);
		    }
		    if (result != TCL_OK) { 
			TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
			        s, (tPtr? tPtr->name : "null")));
			IllegalExprOperandType(interp, pc, valuePtr);
			goto checkForCatch;
		    }
		    tPtr = valuePtr->typePtr;
		}

		/*
		 * Ensure that the operand's string rep is the same as the
		 * formatted version of its internal rep. This makes sure
		 * that "expr +000123" yields "83", not "000123". We
		 * implement this by _discarding_ the string rep since we
		 * know it will be regenerated, if needed later, by
		 * formatting the internal rep's value.
		 */

		if (Tcl_IsShared(valuePtr)) {
		    if (tPtr == &tclIntType) {
			i = valuePtr->internalRep.longValue;
			objPtr = Tcl_NewLongObj(i);
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (tPtr == &tclWideIntType) {
			w = valuePtr->internalRep.wideValue;
			objPtr = Tcl_NewWideIntObj(w);
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			d = valuePtr->internalRep.doubleValue;
			objPtr = Tcl_NewDoubleObj(d);
		    }
		    Tcl_IncrRefCount(objPtr);
		    TclDecrRefCount(valuePtr);
		    valuePtr = objPtr;
		    stackPtr[stackTop] = valuePtr;
		} else {
		    Tcl_InvalidateStringRep(valuePtr);
		}
		TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);

	    }
	    ADJUST_PC(1);

	    
	case INST_UMINUS:
	case INST_LNOT:
	    {
		/*
		 * The operand must be numeric or a boolean string as
		 * accepted by Tcl_GetBooleanFromObj(). If the operand
		 * object is unshared modify it directly, otherwise
		 * create a copy to modify: this is "copy on write".
		 * Free any old string representation since it is now
		 * invalid.
		 */

		double d;
		int boolvar;
		Tcl_ObjType *tPtr;

		valuePtr = POP_OBJECT();
		tPtr = valuePtr->typePtr;
		if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
			|| (valuePtr->bytes != NULL))) {
		    if ((tPtr == &tclBooleanType) 
			    && (valuePtr->bytes == NULL)) {
			valuePtr->typePtr = &tclIntType;
		    } else {
			char *s = Tcl_GetStringFromObj(valuePtr, &length);
			if (TclLooksLikeInt(s, length)) {
			    GET_WIDE_OR_INT(result, valuePtr, i, w);
			} else {
			    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				    valuePtr, &d);
			}
			if (result == TCL_ERROR && *pc == INST_LNOT) {
			    result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
				    valuePtr, &boolvar);
			    i = (long)boolvar; /* i is long, not int! */
			}
			if (result != TCL_OK) {
			    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
				    s, (tPtr? tPtr->name : "null")));
			    IllegalExprOperandType(interp, pc, valuePtr);
			    TclDecrRefCount(valuePtr);
			    goto checkForCatch;
			}
		    }
		    tPtr = valuePtr->typePtr;
		}

		if (Tcl_IsShared(valuePtr)) {
		    /*
		     * Create a new object.
		     */
		    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
			i = valuePtr->internalRep.longValue;
			objPtr = Tcl_NewLongObj(
			        (*pc == INST_UMINUS)? -i : !i);
			TRACE_WITH_OBJ(("%ld => ", i), objPtr);
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (tPtr == &tclWideIntType) {
			w = valuePtr->internalRep.wideValue;
			if (*pc == INST_UMINUS) {
			    objPtr = Tcl_NewWideIntObj(-w);
			} else {
			    objPtr = Tcl_NewLongObj(w == W0);
			}
			LLTRACE_WITH_OBJ((LLD" => ", w), objPtr);
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			d = valuePtr->internalRep.doubleValue;
			if (*pc == INST_UMINUS) {
			    objPtr = Tcl_NewDoubleObj(-d);
			} else {
			    /*
			     * Should be able to use "!d", but apparently
			     * some compilers can't handle it.
			     */
			    objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
			}
			TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
		    }
		    PUSH_OBJECT(objPtr);
		    TclDecrRefCount(valuePtr);
		} else {
		    /*
		     * valuePtr is unshared. Modify it directly.
		     */
		    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
			i = valuePtr->internalRep.longValue;
			Tcl_SetLongObj(valuePtr,
			        (*pc == INST_UMINUS)? -i : !i);
			TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (tPtr == &tclWideIntType) {
			w = valuePtr->internalRep.wideValue;
			if (*pc == INST_UMINUS) {
			    Tcl_SetWideIntObj(valuePtr, -w);
			} else {
			    Tcl_SetLongObj(valuePtr, w == W0);
			}
			LLTRACE_WITH_OBJ((LLD" => ", w), valuePtr);
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			d = valuePtr->internalRep.doubleValue;
			if (*pc == INST_UMINUS) {
			    Tcl_SetDoubleObj(valuePtr, -d);
			} else {
			    /*
			     * Should be able to use "!d", but apparently
			     * some compilers can't handle it.
			     */
			    Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
			}
			TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
		    }
		    ++stackTop; /* valuePtr now on stk top has right r.c. */
		}
	    }
	    ADJUST_PC(1);

	case INST_BITNOT:
	    {
		/*
		 * The operand must be an integer. If the operand object is
		 * unshared modify it directly, otherwise modify a copy. 
		 * Free any old string representation since it is now
		 * invalid.
		 */
		
		Tcl_ObjType *tPtr;
		
		valuePtr = POP_OBJECT();
		tPtr = valuePtr->typePtr;
		if (!IS_INTEGER_TYPE(tPtr)) {
		    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
		    if (result != TCL_OK) {   /* try to convert to double */
			TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
			       O2S(valuePtr), (tPtr? tPtr->name : "null")));
			IllegalExprOperandType(interp, pc, valuePtr);
			TclDecrRefCount(valuePtr);
			goto checkForCatch;
		    }
		}
		
#ifndef TCL_WIDE_INT_IS_LONG
		if (valuePtr->typePtr == &tclWideIntType) {
		    w = valuePtr->internalRep.wideValue;
		    if (Tcl_IsShared(valuePtr)) {
			PUSH_OBJECT(Tcl_NewWideIntObj(~w));
			LLTRACE(("0x%llx => (%llu)\n", w, ~w));
			TclDecrRefCount(valuePtr);
		    } else {
			/*
			 * valuePtr is unshared. Modify it directly.
			 */
			Tcl_SetWideIntObj(valuePtr, ~w);
			++stackTop; /*valuePtr now on stk top has right r.c.*/
			LLTRACE(("0x%llx => (%llu)\n", w, ~w));

		    }
		} else {
#endif /* TCL_WIDE_INT_IS_LONG */
		    i = valuePtr->internalRep.longValue;
		    if (Tcl_IsShared(valuePtr)) {
			PUSH_OBJECT(Tcl_NewLongObj(~i));
			TRACE(("0x%lx => (%lu)\n", i, ~i));
			TclDecrRefCount(valuePtr);
		    } else {
			/*
			 * valuePtr is unshared. Modify it directly.
			 */
			Tcl_SetLongObj(valuePtr, ~i);
			++stackTop; /*valuePtr now on stk top has right r.c.*/
			TRACE(("0x%lx => (%lu)\n", i, ~i));

		    }
#ifndef TCL_WIDE_INT_IS_LONG
		}
#endif /* TCL_WIDE_INT_IS_LONG */
	    }
	    ADJUST_PC(1);

	case INST_CALL_BUILTIN_FUNC1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    {
		/*
		 * Call one of the built-in Tcl math functions.
		 */

		BuiltinFunc *mathFuncPtr;

		if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
		    TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
		    panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
		}
		mathFuncPtr = &(builtinFuncTable[opnd]);
		DECACHE_STACK_INFO();
		result = (*mathFuncPtr->proc)(interp, eePtr,
		        mathFuncPtr->clientData);
		CACHE_STACK_INFO();
		if (result != TCL_OK) {
		    goto checkForCatch;
		}
		TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
	    }
	    ADJUST_PC(2);
		    
	case INST_CALL_FUNC1:
	    opnd = TclGetUInt1AtPtr(pc+1);
	    {
		/*
		 * Call a non-builtin Tcl math function previously
		 * registered by a call to Tcl_CreateMathFunc.
		 */
		
		int objc = opnd;   /* Number of arguments. The function name
				    * is the 0-th argument. */
		Tcl_Obj **objv;	   /* The array of arguments. The function
				    * name is objv[0]. */

		objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
		DECACHE_STACK_INFO();
		result = ExprCallMathFunc(interp, eePtr, objc, objv);
		CACHE_STACK_INFO();
		if (result != TCL_OK) {
		    goto checkForCatch;
		}
		TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
		ADJUST_PC(2);
	    }


	case INST_TRY_CVT_TO_NUMERIC:
	    {
		/*
		 * Try to convert the topmost stack object to an int or
		 * double object. This is done in order to support Tcl's
		 * policy of interpreting operands if at all possible as
		 * first integers, else floating-point numbers.
		 */
		
		double d;
		char *s;
		Tcl_ObjType *tPtr;
		int converted, shared;

		valuePtr = stackPtr[stackTop];
		tPtr = valuePtr->typePtr;
		converted = 0;
		if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
			|| (valuePtr->bytes != NULL))) {
		    if ((tPtr == &tclBooleanType) 
			    && (valuePtr->bytes == NULL)) {
			valuePtr->typePtr = &tclIntType;
			converted = 1;
		    } else {
			s = Tcl_GetStringFromObj(valuePtr, &length);
			if (TclLooksLikeInt(s, length)) {
			    GET_WIDE_OR_INT(result, valuePtr, i, w);
			} else {
			    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
				    valuePtr, &d);
			}
			if (result == TCL_OK) {
			    converted = 1;
			}
			result = TCL_OK; /* reset the result variable */
		    }
		    tPtr = valuePtr->typePtr;
		}

		/*
		 * Ensure that the topmost stack object, if numeric, has a
		 * string rep the same as the formatted version of its
		 * internal rep. This is used, e.g., to make sure that "expr
		 * {0001}" yields "1", not "0001". We implement this by
		 * _discarding_ the string rep since we know it will be
		 * regenerated, if needed later, by formatting the internal
		 * rep's value. Also check if there has been an IEEE
		 * floating point error.
		 */



		if (IS_NUMERIC_TYPE(tPtr)) {
		    shared = 0;
		    if (Tcl_IsShared(valuePtr)) {
			shared = 1;
			if (valuePtr->bytes != NULL) {
			    /*
			     * We only need to make a copy of the object
			     * when it already had a string rep
			     */

			    if (tPtr == &tclIntType) {
				i = valuePtr->internalRep.longValue;
				objPtr = Tcl_NewLongObj(i);
#ifndef TCL_WIDE_INT_IS_LONG
			    } else if (tPtr == &tclWideIntType) {
				w = valuePtr->internalRep.wideValue;
				objPtr = Tcl_NewWideIntObj(w);
#endif /* TCL_WIDE_INT_IS_LONG */
			    } else {
				d = valuePtr->internalRep.doubleValue;
				objPtr = Tcl_NewDoubleObj(d);
			    }
			    Tcl_IncrRefCount(objPtr);
			    TclDecrRefCount(valuePtr);
			    valuePtr = objPtr;
			    stackPtr[stackTop] = valuePtr;
			    tPtr = valuePtr->typePtr;
			}
		    } else {
			Tcl_InvalidateStringRep(valuePtr);
		    }
		
		    if (tPtr == &tclDoubleType) {
			d = valuePtr->internalRep.doubleValue;
			if (IS_NAN(d) || IS_INF(d)) {
			    TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
			           O2S(valuePtr)));
			    TclExprFloatError(interp, d);
			    result = TCL_ERROR;
			    goto checkForCatch;
			}
		    }
		    shared = shared;        /* lint, shared not used. */
		    converted = converted;  /* lint, converted not used. */
		    TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
			   (converted? "converted" : "not converted"),
			   (shared? "shared" : "not shared")));

		} else {
		    TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
		}
	    }
	    ADJUST_PC(1);

	case INST_BREAK:
	    /*
	     * First reset the interpreter's result. Then find the closest
	     * enclosing loop or catch exception range, if any. If a loop is
	     * found, terminate its execution. If the closest is a catch
	     * exception range, jump to its catchOffset. If no enclosing
	     * range is found, stop execution and return TCL_BREAK.
	     */

	    Tcl_ResetResult(interp);
	    rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
	    if (rangePtr == NULL) {
		TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
		result = TCL_BREAK;
		goto abnormalReturn; /* no catch exists to check */
	    }
	    switch (rangePtr->type) {
	    case LOOP_EXCEPTION_RANGE:
		result = TCL_OK;
		TRACE(("=> range at %d, new pc %d\n",
		       rangePtr->codeOffset, rangePtr->breakOffset));
		break;
	    case CATCH_EXCEPTION_RANGE:
		result = TCL_BREAK;
		TRACE(("=> ...\n"));
		goto processCatch; /* it will use rangePtr */
	    default:
		panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
	    }
	    pc = (codePtr->codeStart + rangePtr->breakOffset);
	    continue;	/* restart outer instruction loop at pc */

	case INST_CONTINUE:
            /*
	     * Find the closest enclosing loop or catch exception range,
	     * if any. If a loop is found, skip to its next iteration.
	     * If the closest is a catch exception range, jump to its
	     * catchOffset. If no enclosing range is found, stop
	     * execution and return TCL_CONTINUE.
	     */

	    Tcl_ResetResult(interp);
	    rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
	    if (rangePtr == NULL) {
		TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
		result = TCL_CONTINUE;

		goto abnormalReturn;
	    }
	    switch (rangePtr->type) {
	    case LOOP_EXCEPTION_RANGE:
		if (rangePtr->continueOffset == -1) {
		    TRACE(("=> loop w/o continue, checking for catch\n"));
		    goto checkForCatch;
		} else {
		    result = TCL_OK;
		    TRACE(("=> range at %d, new pc %d\n",
			   rangePtr->codeOffset, rangePtr->continueOffset));
		}
		break;
	    case CATCH_EXCEPTION_RANGE:
		result = TCL_CONTINUE;
		TRACE(("=> ...\n"));
		goto processCatch; /* it will use rangePtr */
	    default:
		panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
	    }
	    pc = (codePtr->codeStart + rangePtr->continueOffset);
	    continue;	/* restart outer instruction loop at pc */

	case INST_FOREACH_START4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    {
	        /*
		 * Initialize the temporary local var that holds the count
		 * of the number of iterations of the loop body to -1.
		 */

		ForeachInfo *infoPtr = (ForeachInfo *)
		    codePtr->auxDataArrayPtr[opnd].clientData;
		int iterTmpIndex = infoPtr->loopCtTemp;
		Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
		Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
		Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;

		if (oldValuePtr == NULL) {
		    iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
		    Tcl_IncrRefCount(iterVarPtr->value.objPtr);
		} else {
		    Tcl_SetLongObj(oldValuePtr, -1);
		}
		TclSetVarScalar(iterVarPtr);
		TclClearVarUndefined(iterVarPtr);
		TRACE(("%u => loop iter count temp %d\n", 
		        opnd, iterTmpIndex));
	    }
	    ADJUST_PC(5);






	




	case INST_FOREACH_STEP4:
	    opnd = TclGetUInt4AtPtr(pc+1);
	    {
	        /*
		 * "Step" a foreach loop (i.e., begin its next iteration) by
		 * assigning the next value list element to each loop var.
		 */

		ForeachInfo *infoPtr = (ForeachInfo *)
		        codePtr->auxDataArrayPtr[opnd].clientData;
		ForeachVarList *varListPtr;
		int numLists = infoPtr->numLists;
		Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
		Tcl_Obj *listPtr;
		List *listRepPtr;
		Var *iterVarPtr, *listVarPtr;
		int iterNum, listTmpIndex, listLen, numVars;
		int varIndex, valIndex, continueLoop, j;

		/*
		 * Increment the temp holding the loop iteration number.
		 */

		iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
		valuePtr = iterVarPtr->value.objPtr;
		iterNum = (valuePtr->internalRep.longValue + 1);
		Tcl_SetLongObj(valuePtr, iterNum);
		
		/*
		 * Check whether all value lists are exhausted and we should
		 * stop the loop.
		 */

		continueLoop = 0;
		listTmpIndex = infoPtr->firstValueTemp;
		for (i = 0;  i < numLists;  i++) {
		    varListPtr = infoPtr->varLists[i];
		    numVars = varListPtr->numVars;
		    
		    listVarPtr = &(compiledLocals[listTmpIndex]);
		    listPtr = listVarPtr->value.objPtr;
		    result = Tcl_ListObjLength(interp, listPtr, &listLen);
		    if (result != TCL_OK) {
			TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
			        opnd, i, O2S(listPtr)),
				Tcl_GetObjResult(interp));
			goto checkForCatch;
		    }
		    if (listLen > (iterNum * numVars)) {
			continueLoop = 1;
		    }
		    listTmpIndex++;
		}

		/*
		 * If some var in some var list still has a remaining list
		 * element iterate one more time. Assign to var the next
		 * element from its value list. We already checked above
		 * that each list temp holds a valid list object.
		 */
		
		if (continueLoop) {
		    listTmpIndex = infoPtr->firstValueTemp;
		    for (i = 0;  i < numLists;  i++) {
			varListPtr = infoPtr->varLists[i];
			numVars = varListPtr->numVars;

			listVarPtr = &(compiledLocals[listTmpIndex]);
			listPtr = listVarPtr->value.objPtr;
			listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
			listLen = listRepPtr->elemCount;
			
			valIndex = (iterNum * numVars);
			for (j = 0;  j < numVars;  j++) {
			    int setEmptyStr = 0;
			    if (valIndex >= listLen) {
				setEmptyStr = 1;
				TclNewObj(valuePtr);
			    } else {
				valuePtr = listRepPtr->elements[valIndex];
			    }
			    
			    varIndex = varListPtr->varIndexes[j];




















			    DECACHE_STACK_INFO();
			    value2Ptr = TclSetIndexedScalar(interp,
			           varIndex, 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++;
		    }
		}


		
		/*
		 * Push 1 if at least one value list had a remaining element
		 * and the loop should continue. Otherwise push 0.



		 */



		PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
		TRACE(("%u => %d lists, iter %d, %s loop\n", 
		        opnd, numLists, iterNum,

		        (continueLoop? "continue" : "exit")));
	    }
	    ADJUST_PC(5);


	case INST_BEGIN_CATCH4:
	    /*
	     * Record start of the catch command with exception range index
	     * equal to the operand. Push the current stack depth onto the
	     * special catch stack.
	     */
	    catchStackPtr[++catchTop] = stackTop;
	    TRACE(("%u => catchTop=%d, stackTop=%d\n",
		    TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
	    ADJUST_PC(5);

	case INST_END_CATCH:
	    catchTop--;
	    result = TCL_OK;
	    TRACE(("=> catchTop=%d\n", catchTop));
	    ADJUST_PC(1);

	case INST_PUSH_RESULT:
	    PUSH_OBJECT(Tcl_GetObjResult(interp));
	    TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
	    ADJUST_PC(1);

	case INST_PUSH_RETURN_CODE:
	    PUSH_OBJECT(Tcl_NewLongObj(result));
	    TRACE(("=> %u\n", result));
	    ADJUST_PC(1);

	default:
	    panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
	} /* end of switch on opCode */

	/*
	 * Division by zero in an expression. Control only reaches this
	 * point by "goto divideByZero".
	 */
	
        divideByZero:
	Tcl_ResetResult(interp);
	Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
			 (char *) NULL);
	result = TCL_ERROR;

	
	/*




	 * 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;
	    }
        }


	rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
	if (rangePtr == NULL) {
#ifdef TCL_COMPILE_DEBUG
	    if (traceInstructions) {
		fprintf(stdout, "   ... no enclosing catch, returning %s\n",
		        StringForResultCode(result));
	    }
#endif
	    goto abnormalReturn;
	}

	/*
	 * A catch exception range (rangePtr) was found to handle an
	 * "exception". It was found either by checkForCatch just above or

	 * by an instruction during break, continue, or error processing.
	 * Jump to its catchOffset after unwinding the operand stack to
	 * the depth it had when starting to execute the range's catch
	 * command.
	 */

        processCatch:
	while (stackTop > catchStackPtr[catchTop]) {
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	}



















































#ifdef TCL_COMPILE_DEBUG
	if (traceInstructions) {






































	    fprintf(stdout, "  ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
	        rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
	        (unsigned int)(rangePtr->catchOffset));
	}
#endif	
	pc = (codePtr->codeStart + rangePtr->catchOffset);
	continue;		/* restart the execution loop at pc */


    } /* end of infinite loop dispatching on instructions */


    /*
     * Abnormal return code. Restore the stack to state it had when starting
     * to execute the ByteCode. Panic if the stack is below the initial level.
     */

    abnormalReturn:
    while (stackTop > initStackTop) {
	valuePtr = POP_OBJECT();
	TclDecrRefCount(valuePtr);
    }
    if (stackTop < initStackTop) {
	fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
		(unsigned int)(pc - codePtr->codeStart),
		(unsigned int) stackTop,
		(unsigned int) initStackTop);
	panic("TclExecuteByteCode execution failure: end stack top < start stack top");
    }
	
    /*
     * Free the catch stack array if malloc'ed storage was used.







|
|


>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
|
|
|
|

|

|

|
|
|
>
|
|
|
|
|
|
|
|
|

|
|
>
|
|
<
|
|
|

|
|
|
<
|
<
|
<
<
<
|

|
|
<
|
|

|
>
|
<
|
|
|
|
|
<
|
|

|
|
|
<
|
|

|
|
|
<
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
<
<
|
|
<
<
<
|
|
|

|
|
|
|

|
|
|

|
|
|
|
|
>
>
>
>
>
|
>
>
|
|
|
>
|
<
<
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|

|
|
|
|

|
|
|
>
|
|
|
|

|
|
|
|
>
>
>
>
>
|
|
>
|
|
|
|
|
|
|
|

|
|

|
|
|

|
|
|
|

|
|
|
|
|

|
|
<
<
<
<
|
<
<
<
|

<
<
<
<
<
|
|
|
|
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
>
|
<
<
<
<
<
<
|
<
<
<
<
|
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<

|
|
<
>
>
|
<
|
<
<
<

<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
>
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
<
<
<
|
<
<
|
<
<
<
<
<
<
<
<
|
<
|
|
|
|
|
|
|
|
|
<
|
|
|
|
>
|
<
>
>
>
|
>
>
>
>
>
|
|
<
>
>
>
|
>
|
>
|
<
>
>
>
|
>
>
>
|
>
>
>
|
|
>
>
>
>
>
|
>
|
<
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
|
<
|
<
|
|
<
<
|
|
<
<
|
>
>
>
>
>

|
|
|
<
|
>
|
|
<
|
<
|
|
|
>
|
>
>
>
|
>
|
>
|
>
>
>

|
|
|
|

|
|
|
|
|
>
>
>
>
|
|
<
>
|
|
<
|
<
|
<
|
|
|
>
|
<
>
>
>
|
>
|
>
|
|
>
>
|
|
>
>
>
>
|
|
|
|
|
|
<
<
|
<
<
|
|
|
<
|
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>

|
>
|
<
>
>
|
>
>
>
>
>
>

|
>
|
<
>
>

|
|
<
|
|
>
|
>
>
>
|
<
<
<
|
<
|
>
>
|
>
>
|
|
>
>
|
<
|
<
<
<
<
<
>
|
|
<
>
>
|
<
<
|
<
<
|
|
|
>
>
>
|
>
>
>
>
|
>
|
>
>
>
>
>
>
|
>
>
>
>
>
|
|
>
>
>
>

|
|
|
>
|

|
|
|
>

|
|
>
|
<
<
<
<
|
|
|
<
|
|
<
<
|
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
|
<
<
|
<
<
<
|
|
|
>
|
<
<
<
<
<
<
<

<
<
<
<
|
|
|
>
>
|

|
|
|
<
<
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
|
<
|
<
|
>
|
<
|
<
<
<
<
<
<
<
<
<
|
>
|
<
|
>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
>
|

|
|
|
>

|
|
|
<
<
<
<
|
<
|
<
|
|
<
<
|
<
<
<
<
<
<
|
<
<
<
|
<
<
<
<
<
|
<
<
<
<
<
|
|
<
<
|
<
<
<
|
<
<
<
<
|
<
<
<
|
|
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<

<
<
>
>
>

<
<
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
>
>
>
|
>
>
|
>
|
>
>
>
|
>
|
>
>
>
>
>
>
>
>
|
|
<
<
>
>
|
>
|
|
<
<
<
<
<
|
|
|
<
<
<
<
<
<
<
|
<
<
<
<
<
<
>
>
>
>

|
>
|
>
>
>
>
|

|
>
>
>
>
|
|
|
|

|
|

|
|
|
|
|
<
|
|
|
|
<
<
<
<
<
<
<
<
|
<
<
<
|
<
|
|
>
>
|
|
<
<
<
<
<
<
<
<
<
>
|
|
<
<
<
<
|
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
>
|
<
|
>
|
<
<
<
<
<
|
|
|
<
|
|
<
|
<
<
>
>
|
>
>
>
>
>
|
>
|
>
|
<
|
<
|
>
|
>
|
|
<
|
<
|
|
|
<
<
|
|
<
<
<
<
<
<
<
|
<
<
<
>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
<
<
<
<
|
|
|
>
|
>
>
>
>
>
>
>
>
>
>
<
<
<
<
<
<
<
|
<
<
<

<
<
>
|
|
<
>
|
<
<
|
<
<
<
|
<
<
<
|
>
>
|
<
>
<

<
<
<
<
<
<
<
<
|
<
|
|
|
|
<
>
|
<
<
|
|
<
|
<
|
|
<

|
|

|
<
<
|
<
<



<
<
>
|
<
<
>
|
>
|
>
>
>
|
|
>
|

>
|
<
|
|
|
|
<
<
<
<

|
|
|
|
>
|
>
>
>
>

|
|
|
|

>
>
>
>
>
|
|
|

|
|
|

|
|
|
|
|

|
|

|
|
|
|
<
<
|
|
|
>
>
>
|
>
|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
|
<
|
>
|
|
|
<
<

>
|
<
|
<
>
|
|
>
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|

|
|

|
|

|
|
|
|
|

|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
<
|
|
<
<
|
|
|

|
|

|
|

|
|
|
|
|

|
|
|

|
|
|
|
|
|

|
|
<
|
|
|
<
|
|
<
<
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
<
|
<
>
|
>
|
>
>
>
>
|
>
>
>
>
>
|
>
>
>
>

|
|

|
|
|
|
<
|
|
|
|
<
|

|
|

|
|
|
|
|

|
|
|
|
|
|
<
|
<
<
|
|
|

|
|
|
<
|
|
|
<
<
<

|
|
|
|
|
|
|

|

|
|

|
|
|
|
|

|
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
|
<
|
|
|

|
|
|
<
|
<
>
|
<

|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
<

<
<
<
<
<
<
<

<
<
<
<
|
|
|
|
|
<
|
|
|

|
|
|
<
|
<
>
|
<

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<

|
|
|
|
|
|
|
|
|

|
|
|
<
|
>
|
>
|
>
>

|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

<
|
|
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
>
|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|
|
<
<
|
<

|
|
|

|

|
|
|
|
|
|
|
<
>
|
<

|
|
|
|
|
|
|

|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
<
|
<
<
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

<
|
|
<
<
>
|
<

|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
|

|
|
>
|

|
<
<
|
|
<
>
|
|
<
>
|
|
<
<
<
<

|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

<
<
<
|
|
|
>
>
|
>
|
|
>
>
|
|
<
>
>
>
>
>
>
|
<
>
>
>
|
<

|
|
|
|
|
|
|
|
|
|

|
|

|
|


|
|
|
|

|
|

|
|
|
|
|
|
|
|
<
<
|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
<
<
|
|
|

|
|
|
|
|
|
|
|

|
|
<
<
|
|

|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
<
<
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|

|

|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|

|

|
|
|
|
|
|
|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|

|

|
|
|
|

|
|

|

|
|

|
|
|
|

|
|

|

|
|
<
|
<

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|


|
|
|
|

|
|

|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|

|
|

|
|

|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|

|
|
|

|
|
|
|
|
<
<
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|


|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|

|
|
|

|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
|
<
|
<

|
|
|
|
|

|
|

|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|

|
|
|

|
|
|
|
|
|
<
<
|
|
<
|
>
|
<
>

|
|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<

|
|
|
|
|
|
|
|

|

|
|
|
|
|
|
|
|
<
|
|
|


|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|

|
|
|
|
|
|
|
|
|
|
<
|
>
|

|

|
<

|
|
|
|
|
|

|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
<
|
>

|
|
|
|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
>
>
|
<
|
<
|
|
|
|
|
>
|
|
|

|
|
|

|
|
|
|
<
<
|
<
<
|
|
|
|

|
|
|
|
|
|
|
|
|
|
<
|
|
|
<
>
|
|
|
<
<
|
|
<
<
<
<
<
<
<
|
<
|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
|
<
<
<
<
<
<
<
<
|
<
<
<
|
>
|
|
<
|
<
<
<
|
|
<
<
<
|
<
<
<
|
<
<
<
<
<

|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
|
>
>
>
>
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|

|
|
|
|

|
|
|
|

|
|
|
|
|

|
|
|
|
|
|
<
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|

|
|
|
|

|
|
|
|
|
|
|
|
|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|



|
|






>
|
|
|
|
|
>
>
|
|
<
<
>
>
>
|

>
>
|
<
<
>
|

<
>

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|

|
|
|

|
|
|
|

|
|
|
|
|
|
>

|
>
>
>
>
|
|
<
>
|
>
>
>
>
>
>
>
|
|
|
|
|
|
|
<
<
|
<
>
>
|

<
<
|
|
<
<

|
|
<
<
<
>
|
<
<
<
<
|
<
|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|


|

|
|
>
>
|
>






|






|







1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253

1254
1255
1256
1257
1258
1259
1260

1261

1262



1263
1264
1265
1266

1267
1268
1269
1270
1271
1272

1273
1274
1275
1276
1277

1278
1279
1280
1281
1282
1283

1284
1285
1286
1287
1288
1289

1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322

1323
1324



1325
1326



1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357


1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440




1441



1442
1443





1444
1445
1446
1447
1448




1449

























1450
1451
1452
1453
1454
1455






1456




1457


1458



1459








1460
1461
1462

1463
1464
1465

1466



1467









1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479











1480





















1481






1482




1483


1484








1485

1486
1487
1488
1489
1490
1491
1492
1493
1494

1495
1496
1497
1498
1499
1500

1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511

1512
1513
1514
1515
1516
1517
1518
1519

1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540

1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557

1558

1559
1560


1561
1562


1563
1564
1565
1566
1567
1568
1569
1570
1571
1572

1573
1574
1575
1576

1577

1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610

1611
1612
1613

1614

1615

1616
1617
1618
1619
1620

1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643


1644


1645
1646
1647

1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674

1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687

1688
1689
1690
1691
1692

1693
1694
1695
1696
1697
1698
1699
1700



1701

1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712

1713





1714
1715
1716

1717
1718
1719


1720


1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768




1769
1770
1771

1772
1773


1774






1775






1776

1777


1778



1779
1780
1781
1782
1783







1784




1785
1786
1787
1788
1789
1790
1791
1792
1793
1794





1795





1796







1797







1798

1799

1800
1801
1802

1803









1804
1805
1806

1807
1808
1809
1810














1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824




1825

1826

1827
1828


1829






1830



1831





1832





1833
1834


1835



1836




1837



1838
1839
1840




1841











1842



1843


1844
1845
1846
1847


1848







1849










1850
1851































































1852

1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877


1878
1879
1880
1881
1882
1883





1884
1885
1886







1887






1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919

1920
1921
1922
1923








1924



1925

1926
1927
1928
1929
1930
1931









1932
1933
1934




1935
1936

1937

















1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951

1952
1953
1954





1955
1956
1957

1958
1959

1960


1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973

1974

1975
1976
1977
1978
1979
1980

1981

1982
1983
1984


1985
1986







1987



1988
1989
1990













1991
1992
1993








1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008







2009



2010


2011
2012
2013

2014
2015


2016



2017



2018
2019
2020
2021

2022

2023








2024

2025
2026
2027
2028

2029
2030


2031
2032

2033

2034
2035

2036
2037
2038
2039
2040


2041


2042
2043
2044


2045
2046


2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060

2061
2062
2063
2064




2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107


2108
2109
2110
2111
2112
2113
2114
2115
2116

2117































2118




2119

2120
2121
2122
2123
2124


2125
2126
2127

2128

2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182

2183
2184


2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213

2214
2215
2216

2217
2218


2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235

2236
2237

2238

2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265

2266
2267
2268
2269

2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286

2287


2288
2289
2290
2291
2292
2293
2294

2295
2296
2297



2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318












2319
2320
2321
2322

2323
2324
2325
2326
2327
2328
2329

2330

2331
2332

2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362

2363







2364




2365
2366
2367
2368
2369

2370
2371
2372
2373
2374
2375
2376

2377

2378
2379

2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401


2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415

2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462

2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552


2553

2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567

2568
2569

2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598

2599


2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624

2625
2626


2627
2628

2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656


2657
2658

2659
2660
2661

2662
2663
2664




2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876



2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889

2890
2891
2892
2893
2894
2895
2896

2897
2898
2899
2900

2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935


2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952


2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967


2968
2969
2970
2971
2972
2973
2974
2975
2976


2977
2978
2979
2980
2981
2982
2983
2984


2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168

3169

3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226


3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260


3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294


3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309


3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342


3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380


3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429

3430

3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449

3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483


3484
3485

3486
3487
3488

3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511

3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529

3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568

3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603

3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623

3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639

3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654

3655
3656
3657
3658
3659
3660
3661

3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708

3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731

3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763

3764

3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782


3783


3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798

3799
3800
3801

3802
3803
3804
3805


3806
3807







3808

3809




3810












3811


3812
3813








3814



3815
3816
3817
3818

3819



3820
3821



3822



3823





3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907

3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988


3989
3990
3991
3992
3993
3994
3995
3996


3997
3998
3999

4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052

4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068


4069

4070
4071
4072
4073


4074
4075


4076
4077
4078



4079
4080




4081

4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208

    while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
        GrowEvaluationStack(eePtr); 
        stackPtr = eePtr->stackPtr;
    }

    /*
     * Loop executing instructions until a "done" instruction, a 
     * TCL_RETURN, or some error.
     */

    goto cleanup0;

    
    /*
     * Targets for standard instruction endings; unrolled
     * for speed in the most frequent cases (instructions that 
     * consume up to two stack elements).
     *
     * This used to be a "for(;;)" loop, with each instruction doing
     * its own cleanup.
     */
    
    cleanupV_pushObjResultPtr:
    switch (cleanup) {
        case 0:
	    stackPtr[++stackTop] = (objResultPtr);
	    goto cleanup0;
        default:
	    cleanup -= 2;
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
        case 2: 
        cleanup2_pushObjResultPtr:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
        case 1: 
        cleanup1_pushObjResultPtr:
	    valuePtr = stackPtr[stackTop];
	    TclDecrRefCount(valuePtr);
    }
    stackPtr[stackTop] = objResultPtr;
    goto cleanup0;
    
    cleanupV:
    switch (cleanup) {
        default:
	    cleanup -= 2;
	    while (cleanup--) {
		valuePtr = POP_OBJECT();
		TclDecrRefCount(valuePtr);
	    }
        case 2: 
        cleanup2:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
        case 1: 
        cleanup1:
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
        case 0:
	    /*
	     * We really want to do nothing now, but this is needed
	     * for some compilers (SunPro CC)
	     */
	    break;
    }

    cleanup0:
    
#ifdef TCL_COMPILE_DEBUG
    ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
    if (traceInstructions) {
	fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
	TclPrintInstruction(codePtr, pc);
	fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */
    
#ifdef TCL_COMPILE_STATS    
    iPtr->stats.instructionCount[*pc]++;
#endif
    switch (*pc) {
    case INST_DONE:
	if (stackTop <= initStackTop) {
	    stackTop--;
	    goto abnormalReturn;
	}
	
	/*
	 * Set the interpreter's object result to point to the 
	 * topmost object from the stack, and check for a possible
	 * [catch]. The stackTop's level and refCount will be handled 
	 * by "processCatch" or "abnormalReturn".
	 */

	valuePtr = stackPtr[stackTop];
	Tcl_SetObjResult(interp, valuePtr);
#ifdef TCL_COMPILE_DEBUG	    
	TRACE_WITH_OBJ(("=> return code=%d, result=", result),
	        iPtr->objResultPtr);

	if (traceInstructions) {
	    fprintf(stdout, "\n");
	}
#endif
	goto checkForCatch;
	
    case INST_PUSH1:

	objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];

	TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);



	NEXT_INST_F(2, 0, 1);

    case INST_PUSH4:
	objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];

	TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
	NEXT_INST_F(5, 0, 1);

    case INST_POP:
	TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
	valuePtr = POP_OBJECT();

	TclDecrRefCount(valuePtr);
	NEXT_INST_F(1, 0, 0);
	
    case INST_DUP:
	objResultPtr = stackPtr[stackTop];

	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(1, 0, 1);

    case INST_OVER:
	opnd = TclGetUInt4AtPtr( pc+1 );
	objResultPtr = stackPtr[ stackTop - opnd ];

	TRACE_WITH_OBJ(("=> "), objResultPtr);
	NEXT_INST_F(5, 0, 1);

    case INST_CONCAT1:
	opnd = TclGetUInt1AtPtr(pc+1);
	{

	    int totalLen = 0;
	    
	    /*
	     * Concatenate strings (with no separators) from the top
	     * opnd items on the stack starting with the deepest item.
	     * First, determine how many characters are needed.
	     */

	    for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
		bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
		if (bytes != NULL) {
		    totalLen += length;
		}
	    }

	    /*
	     * Initialize the new append string object by appending the
	     * strings of the opnd stack objects. Also pop the objects. 
	     */

	    TclNewObj(objResultPtr);
	    if (totalLen > 0) {
		char *p = (char *) ckalloc((unsigned) (totalLen + 1));
		objResultPtr->bytes = p;
		objResultPtr->length = totalLen;
		for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
		    valuePtr = stackPtr[i];
		    bytes = Tcl_GetStringFromObj(valuePtr, &length);
		    if (bytes != NULL) {
			memcpy((VOID *) p, (VOID *) bytes,
			       (size_t) length);
			p += length;
		    }

		}
		*p = '\0';



	    }
		



	    TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	    NEXT_INST_V(2, opnd, 1);
	}
	    
    case INST_INVOKE_STK4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	goto doInvocation;

    case INST_INVOKE_STK1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	    
    doInvocation:
	{
	    int objc = opnd; /* The number of arguments. */
	    Tcl_Obj **objv;	 /* The array of argument objects. */

	    /*
	     * We keep the stack reference count as a (char *), as that
	     * works nicely as a portable pointer-sized counter.
	     */

	    char **preservedStackRefCountPtr;
	    
	    /* 
	     * Reference to memory block containing
	     * objv array (must be kept live throughout
	     * trace and command invokations.) 
	     */



	    objv = &(stackPtr[stackTop - (objc-1)]);

#ifdef TCL_COMPILE_DEBUG
	    if (tclTraceExec >= 2) {
		if (traceInstructions) {
		    strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
		    TRACE(("%u => call ", objc));
		} else {
		    fprintf(stdout, "%d: (%u) invoking ",
			    iPtr->numLevels,
			    (unsigned int)(pc - codePtr->codeStart));
		}
		for (i = 0;  i < objc;  i++) {
		    TclPrintObject(stdout, objv[i], 15);
		    fprintf(stdout, " ");
		}
		fprintf(stdout, "\n");
		fflush(stdout);
	    }
#endif /*TCL_COMPILE_DEBUG*/

	    /* 
	     * If trace procedures will be called, we need a
	     * command string to pass to TclEvalObjvInternal; note 
	     * that a copy of the string will be made there to 
	     * include the ending \0.
	     */

	    bytes = NULL;
	    length = 0;
	    if (iPtr->tracePtr != NULL) {
		Trace *tracePtr, *nextTracePtr;
		    
		for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
		     tracePtr = nextTracePtr) {
		    nextTracePtr = tracePtr->nextPtr;
		    if (tracePtr->level == 0 ||
			iPtr->numLevels <= tracePtr->level) {
			/*
			 * Traces will be called: get command string
			 */

			bytes = GetSrcInfoForPc(pc, codePtr, &length);
			break;
		    }
		}
	    } else {		
		Command *cmdPtr;
		cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
		if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
		    bytes = GetSrcInfoForPc(pc, codePtr, &length);
		}
	    }		

	    /*
	     * A reference to part of the stack vector itself
	     * escapes our control: increase its refCount
	     * to stop it from being deallocated by a recursive
	     * call to ourselves.  The extra variable is needed
	     * because all others are liable to change due to the
	     * trace procedures.
	     */

	    preservedStackRefCountPtr = (char **) (stackPtr-1);
	    ++*preservedStackRefCountPtr;

	    /*
	     * Finally, let TclEvalObjvInternal handle the command. 
	     */

	    Tcl_ResetResult(interp);
	    DECACHE_STACK_INFO();
	    result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
	    CACHE_STACK_INFO();

	    /*
	     * If the old stack is going to be released, it is
	     * safe to do so now, since no references to objv are
	     * going to be used from now on.
	     */

	    --*preservedStackRefCountPtr;
	    if (*preservedStackRefCountPtr == (char *) 0) {




		ckfree((VOID *) preservedStackRefCountPtr);



	    }	    






	    if (result == TCL_OK) {
		/*
		 * Push the call's object result and continue execution
		 * with the next instruction.
		 */






























		TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
		        objc, cmdNameBuf), Tcl_GetObjResult(interp));

		objResultPtr = Tcl_GetObjResult(interp);
		NEXT_INST_V(pcAdjustment, opnd, 1);
	    } else {






		cleanup = opnd;




		goto processExceptionReturn;


	    }



	}









    case INST_EVAL_STK:
	/*

	 * Note to maintainers: it is important that INST_EVAL_STK
	 * pop its argument from the stack before jumping to
	 * checkForCatch! DO NOT OPTIMISE!

	 */













	objPtr = stackPtr[stackTop];
	DECACHE_STACK_INFO();
	result = TclCompEvalObj(interp, objPtr);
	CACHE_STACK_INFO();
	if (result == TCL_OK) {
	    /*
	     * Normal return; push the eval's object result.
	     */

	    objResultPtr = Tcl_GetObjResult(interp);
	    TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
			   Tcl_GetObjResult(interp));











	    NEXT_INST_F(1, 1, 1);





















	} else {






	    cleanup = 1;




	    goto processExceptionReturn;


	}










    case INST_EXPR_STK:
	objPtr = stackPtr[stackTop];
	Tcl_ResetResult(interp);
	DECACHE_STACK_INFO();
	result = Tcl_ExprObj(interp, objPtr, &valuePtr);
	CACHE_STACK_INFO();
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", 
	        O2S(objPtr)), Tcl_GetObjResult(interp));

	    goto checkForCatch;
	}
	objResultPtr = valuePtr;
	TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
	NEXT_INST_F(1, 1, -1); /* already has right refct */


    /*
     * ---------------------------------------------------------
     *     Start of INST_LOAD instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!
     * The different instructions set the value of some variables
     * and then jump to somme common execution code.
     */

    case INST_LOAD_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);

	varPtr = &(varFramePtr->compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));
	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) 
	        && (varPtr->tracePtr == NULL)) {

	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_F(2, 0, 1);
	}
	pcAdjustment = 2;
	cleanup = 0;
	arrayPtr = NULL;
	part2 = NULL;
	goto doCallPtrGetVar;

    case INST_LOAD_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	varPtr = &(varFramePtr->compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	TRACE(("%u => ", opnd));

	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) 
	        && (varPtr->tracePtr == NULL)) {
	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_F(5, 0, 1);
	}
	pcAdjustment = 5;
	cleanup = 0;
	arrayPtr = NULL;
	part2 = NULL;
	goto doCallPtrGetVar;

    case INST_LOAD_ARRAY_STK:
	cleanup = 2;

	part2 = Tcl_GetString(stackPtr[stackTop]);  /* element name */

	objPtr = stackPtr[stackTop-1]; /* array name */
	TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));


	goto doLoadStk;



    case INST_LOAD_STK:
    case INST_LOAD_SCALAR_STK:
	cleanup = 1;
	part2 = NULL;
	objPtr = stackPtr[stackTop]; /* variable name */
	TRACE(("\"%.30s\" => ", O2S(objPtr)));

    doLoadStk:
	part1 = TclGetString(objPtr);
	varPtr = TclObjLookupVar(interp, objPtr, part2, 

	         TCL_LEAVE_ERR_MSG, "read",
                 /*createPart1*/ 0,
	         /*createPart2*/ 1, &arrayPtr);
	if (varPtr == NULL) {

	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));

	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) 
	        && (varPtr->tracePtr == NULL)
	        && ((arrayPtr == NULL) 
		        || (arrayPtr->tracePtr == NULL))) {
	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_V(1, cleanup, 1);
	}
	pcAdjustment = 1;
	goto doCallPtrGetVar;

    case INST_LOAD_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	goto doLoadArray;

    case INST_LOAD_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
    
    doLoadArray:
	part2 = TclGetString(stackPtr[stackTop]);
	arrayPtr = &(varFramePtr->compiledLocals[opnd]);
	part1 = arrayPtr->name;
	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;
	}

	TRACE(("%u \"%.30s\" => ", opnd, part2));
	varPtr = TclLookupArrayElement(interp, part1, part2, 
	        TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);

	if (varPtr == NULL) {

	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));

	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) 
	        && (varPtr->tracePtr == NULL)

	        && ((arrayPtr == NULL) 
		        || (arrayPtr->tracePtr == NULL))) {
	    /*
	     * No errors, no traces: just get the value.
	     */
	    objResultPtr = varPtr->value.objPtr;
	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	    NEXT_INST_F(pcAdjustment, 1, 1);
	}
	cleanup = 1;
	goto doCallPtrGetVar;

    doCallPtrGetVar:
	/*
	 * There are either errors or the variable is traced:
	 * call TclPtrGetVar to process fully.
	 */

	DECACHE_STACK_INFO();
	objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, 
	        part2, TCL_LEAVE_ERR_MSG);
	CACHE_STACK_INFO();
	if (objResultPtr == NULL) {


	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));


	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_V(pcAdjustment, cleanup, 1);

    /*
     *     End of INST_LOAD instructions.
     * ---------------------------------------------------------
     */

    /*
     * ---------------------------------------------------------
     *     Start of INST_STORE and related instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!
     * The different instructions set the value of some variables
     * and then jump to somme common execution code.
     */

    case INST_LAPPEND_STK:
	valuePtr = stackPtr[stackTop]; /* value to append */
	part2 = NULL;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		      | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreStk;

    case INST_LAPPEND_ARRAY_STK:
	valuePtr = stackPtr[stackTop]; /* value to append */
	part2 = TclGetString(stackPtr[stackTop - 1]);

	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		      | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreStk;

    case INST_APPEND_STK:
	valuePtr = stackPtr[stackTop]; /* value to append */
	part2 = NULL;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreStk;

    case INST_APPEND_ARRAY_STK:
	valuePtr = stackPtr[stackTop]; /* value to append */
	part2 = TclGetString(stackPtr[stackTop - 1]);

	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreStk;

    case INST_STORE_ARRAY_STK:
	valuePtr = stackPtr[stackTop];

	part2 = TclGetString(stackPtr[stackTop - 1]);
	storeFlags = TCL_LEAVE_ERR_MSG;
	goto doStoreStk;

    case INST_STORE_STK:
    case INST_STORE_SCALAR_STK:
	valuePtr = stackPtr[stackTop];
	part2 = NULL;



	storeFlags = TCL_LEAVE_ERR_MSG;


    doStoreStk:
	objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
	part1 = TclGetString(objPtr);
#ifdef TCL_COMPILE_DEBUG
	if (part2 == NULL) {
	    TRACE(("\"%.30s\" <- \"%.30s\" =>", 
	            part1, O2S(valuePtr)));
	} else {
	    TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
		    part1, part2, O2S(valuePtr)));

	}





#endif
	varPtr = TclObjLookupVar(interp, objPtr, part2, 
	         TCL_LEAVE_ERR_MSG, "set",

                 /*createPart1*/ 1,
	         /*createPart2*/ 1, &arrayPtr);
	if (varPtr == NULL) {


	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));


	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	cleanup = ((part2 == NULL)? 2 : 3);
	pcAdjustment = 1;
	goto doCallPtrSetVar;

    case INST_LAPPEND_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		      | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreArray;

    case INST_LAPPEND_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		      | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreArray;

    case INST_APPEND_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreArray;

    case INST_APPEND_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreArray;

    case INST_STORE_ARRAY4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = TCL_LEAVE_ERR_MSG;
	goto doStoreArray;

    case INST_STORE_ARRAY1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = TCL_LEAVE_ERR_MSG;
	    
    doStoreArray:
	valuePtr = stackPtr[stackTop];
	part2 = TclGetString(stackPtr[stackTop - 1]);
	arrayPtr = &(varFramePtr->compiledLocals[opnd]);




	part1 = arrayPtr->name;
	TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
		    opnd, part2, O2S(valuePtr)));

	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;


	}






	varPtr = TclLookupArrayElement(interp, part1, part2, 






	        TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);

	if (varPtr == NULL) {


	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));



	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	cleanup = 2;
	goto doCallPtrSetVar;












    case INST_LAPPEND_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 
		      | TCL_LIST_ELEMENT | TCL_TRACE_READS);
	goto doStoreScalar;

    case INST_LAPPEND_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;	    





	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE 





		      | TCL_LIST_ELEMENT | TCL_TRACE_READS);







	goto doStoreScalar;









    case INST_APPEND_SCALAR4:

	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);

	goto doStoreScalar;










    case INST_APPEND_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);

	pcAdjustment = 2;	    
	storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
	goto doStoreScalar;















    case INST_STORE_SCALAR4:
	opnd = TclGetUInt4AtPtr(pc+1);
	pcAdjustment = 5;
	storeFlags = TCL_LEAVE_ERR_MSG;
	goto doStoreScalar;

    case INST_STORE_SCALAR1:
	opnd = TclGetUInt1AtPtr(pc+1);
	pcAdjustment = 2;
	storeFlags = TCL_LEAVE_ERR_MSG;

    doStoreScalar:
	valuePtr = stackPtr[stackTop];
	varPtr = &(varFramePtr->compiledLocals[opnd]);




	part1 = varPtr->name;

	TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));

	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;


	}






	cleanup = 1;



	arrayPtr = NULL;





	part2 = NULL;






    doCallPtrSetVar:


	if ((storeFlags == TCL_LEAVE_ERR_MSG)



	        && !((varPtr->flags & VAR_IN_HASHTABLE) 




		        && (varPtr->hPtr == NULL))



	        && (varPtr->tracePtr == NULL)
	        && (TclIsVarScalar(varPtr) 
		        || TclIsVarUndefined(varPtr))




	        && ((arrayPtr == NULL) 











		        || (arrayPtr->tracePtr == NULL))) {



	    /*


	     * No traces, no errors, plain 'set': we can safely inline.
	     * The value *will* be set to what's requested, so that 
	     * the stack top remains pointing to the same Tcl_Obj.
	     */


	    valuePtr = varPtr->value.objPtr;







	    objResultPtr = stackPtr[stackTop];










	    if (valuePtr != objResultPtr) {
		if (valuePtr != NULL) {































































		    TclDecrRefCount(valuePtr);

		} else {
		    TclSetVarScalar(varPtr);
		    TclClearVarUndefined(varPtr);
		}
		varPtr->value.objPtr = objResultPtr;
		Tcl_IncrRefCount(objResultPtr);
	    }
#ifndef TCL_COMPILE_DEBUG
	    if (*(pc+pcAdjustment) == INST_POP) {
		NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	    }
#else
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
	    NEXT_INST_V(pcAdjustment, cleanup, 1);
	} else {
	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, 
	            part1, part2, valuePtr, storeFlags);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {
		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
		result = TCL_ERROR;
		goto checkForCatch;
	    }


	}
#ifndef TCL_COMPILE_DEBUG
	if (*(pc+pcAdjustment) == INST_POP) {
	    NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	}
#endif





	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	NEXT_INST_V(pcAdjustment, cleanup, 1);















    /*
     *     End of INST_STORE and related instructions.
     * ---------------------------------------------------------
     */

    /*
     * ---------------------------------------------------------
     *     Start of INST_INCR instructions.
     *
     * WARNING: more 'goto' here than your doctor recommended!
     * The different instructions set the value of some variables
     * and then jump to somme common execution code.
     */

    case INST_INCR_SCALAR1:
    case INST_INCR_ARRAY1:
    case INST_INCR_ARRAY_STK:
    case INST_INCR_SCALAR_STK:
    case INST_INCR_STK:
	opnd = TclGetUInt1AtPtr(pc+1);
	valuePtr = stackPtr[stackTop];
	if (valuePtr->typePtr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
#endif /* TCL_WIDE_INT_IS_LONG */
	} else {
	    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
	    if (result != TCL_OK) {
		TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
		        opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));

		goto checkForCatch;
	    }
	    FORCE_LONG(valuePtr, i, w);
	}








	stackTop--;



	TclDecrRefCount(valuePtr);

	switch (*pc) {
	    case INST_INCR_SCALAR1:
		pcAdjustment = 2;
		goto doIncrScalar;
	    case INST_INCR_ARRAY1:
		pcAdjustment = 2;









		goto doIncrArray;
	    default:
		pcAdjustment = 1;




		goto doIncrStk;
	}



















    case INST_INCR_ARRAY_STK_IMM:
    case INST_INCR_SCALAR_STK_IMM:
    case INST_INCR_STK_IMM:
	i = TclGetInt1AtPtr(pc+1);
	pcAdjustment = 2;
	    
    doIncrStk:
	if ((*pc == INST_INCR_ARRAY_STK_IMM) 
	        || (*pc == INST_INCR_ARRAY_STK)) {
	    part2 = TclGetString(stackPtr[stackTop]);
	    objPtr = stackPtr[stackTop - 1];
	    TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
		    O2S(objPtr), part2, i));
	} else {

	    part2 = NULL;
	    objPtr = stackPtr[stackTop];
	    TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));





	}
	part1 = TclGetString(objPtr);


	varPtr = TclObjLookupVar(interp, objPtr, part2, 
	        TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);

	if (varPtr == NULL) {


	    Tcl_AddObjErrorInfo(interp,
	            "\n    (reading value of variable to increment)", -1);
	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}
	cleanup = ((part2 == NULL)? 1 : 2);
	goto doIncrVar;

    case INST_INCR_ARRAY1_IMM:
	opnd = TclGetUInt1AtPtr(pc+1);
	i = TclGetInt1AtPtr(pc+2);
	pcAdjustment = 3;



    doIncrArray:
	part2 = TclGetString(stackPtr[stackTop]);
	arrayPtr = &(varFramePtr->compiledLocals[opnd]);
	part1 = arrayPtr->name;
	while (TclIsVarLink(arrayPtr)) {
	    arrayPtr = arrayPtr->value.linkPtr;

	}

	TRACE(("%u \"%.30s\" (by %ld) => ",
		    opnd, part2, i));
	varPtr = TclLookupArrayElement(interp, part1, part2, 


	        TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
	if (varPtr == NULL) {







	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));



	    result = TCL_ERROR;
	    goto checkForCatch;
	}













	cleanup = 1;
	goto doIncrVar;









    case INST_INCR_SCALAR1_IMM:
	opnd = TclGetUInt1AtPtr(pc+1);
	i = TclGetInt1AtPtr(pc+2);
	pcAdjustment = 3;

    doIncrScalar:
	varPtr = &(varFramePtr->compiledLocals[opnd]);
	part1 = varPtr->name;
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	arrayPtr = NULL;
	part2 = NULL;
	cleanup = 0;
	TRACE(("%u %ld => ", opnd, i));














    doIncrVar:
	objPtr = varPtr->value.objPtr;
	if (TclIsVarScalar(varPtr)

	        && !TclIsVarUndefined(varPtr) 
	        && (varPtr->tracePtr == NULL)


	        && ((arrayPtr == NULL) 



		        || (arrayPtr->tracePtr == NULL))



	        && (objPtr->typePtr == &tclIntType)) {
	    /*
	     * No errors, no traces, the variable already has an
	     * integer value: inline processing.

	     */










	    i += objPtr->internalRep.longValue;

	    if (Tcl_IsShared(objPtr)) {
		objResultPtr = Tcl_NewLongObj(i);
		TclDecrRefCount(objPtr);
		Tcl_IncrRefCount(objResultPtr);

		varPtr->value.objPtr = objResultPtr;
	    } else {


		Tcl_SetLongObj(objPtr, i);
		objResultPtr = objPtr;

	    }

	    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
	} else {

	    DECACHE_STACK_INFO();
	    objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, 
                    part2, i, TCL_LEAVE_ERR_MSG);
	    CACHE_STACK_INFO();
	    if (objResultPtr == NULL) {


		TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));


		result = TCL_ERROR;
		goto checkForCatch;
	    }


	}
	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));


#ifndef TCL_COMPILE_DEBUG
	if (*(pc+pcAdjustment) == INST_POP) {
	    NEXT_INST_V((pcAdjustment+1), cleanup, 0);
	}
#endif
	NEXT_INST_V(pcAdjustment, cleanup, 1);
	    	    
    /*
     *     End of INST_INCR instructions.
     * ---------------------------------------------------------
     */


    case INST_JUMP1:

	opnd = TclGetInt1AtPtr(pc+1);
	TRACE(("%d => new pc %u\n", opnd,
	        (unsigned int)(pc + opnd - codePtr->codeStart)));
	NEXT_INST_F(opnd, 0, 0);





    case INST_JUMP4:
	opnd = TclGetInt4AtPtr(pc+1);
	TRACE(("%d => new pc %u\n", opnd,
	        (unsigned int)(pc + opnd - codePtr->codeStart)));
	NEXT_INST_F(opnd, 0, 0);

    case INST_JUMP_FALSE4:
	opnd = 5;                             /* TRUE */
	pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
	goto doJumpTrue;

    case INST_JUMP_TRUE4:
	opnd = TclGetInt4AtPtr(pc+1);         /* TRUE */
	pcAdjustment = 5;                     /* FALSE */
	goto doJumpTrue;

    case INST_JUMP_FALSE1:
	opnd = 2;                             /* TRUE */
	pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
	goto doJumpTrue;

    case INST_JUMP_TRUE1:
	opnd = TclGetInt1AtPtr(pc+1);          /* TRUE */
	pcAdjustment = 2;                      /* FALSE */
	    
    doJumpTrue:
	{
	    int b;
		
	    valuePtr = stackPtr[stackTop];
	    if (valuePtr->typePtr == &tclIntType) {
		b = (valuePtr->internalRep.longValue != 0);
	    } else if (valuePtr->typePtr == &tclDoubleType) {
		b = (valuePtr->internalRep.doubleValue != 0.0);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (valuePtr->typePtr == &tclWideIntType) {
		b = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
		if (result != TCL_OK) {
		    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));


		    goto checkForCatch;
		}
	    }
#ifndef TCL_COMPILE_DEBUG
	    NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
#else
	    if (b) {
		if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
		    TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),

		            (unsigned int)(pc+opnd - codePtr->codeStart)));































		} else {




		    TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));

		}
		NEXT_INST_F(opnd, 1, 0);
	    } else {
		if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
		    TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));


		} else {
		    opnd = pcAdjustment;
		    TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),

		            (unsigned int)(pc + opnd - codePtr->codeStart)));

		}
		NEXT_INST_F(pcAdjustment, 1, 0);
	    }
#endif
	}
	    	    
    case INST_LOR:
    case INST_LAND:
    {
	/*
	 * Operands must be boolean or numeric. No int->double
	 * conversions are performed.
	 */
		
	int i1, i2;
	int iResult;
	char *s;
	Tcl_ObjType *t1Ptr, *t2Ptr;

	value2Ptr = stackPtr[stackTop];
	valuePtr  = stackPtr[stackTop - 1];;
	t1Ptr = valuePtr->typePtr;
	t2Ptr = value2Ptr->typePtr;

	if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
	    i1 = (valuePtr->internalRep.longValue != 0);
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (t1Ptr == &tclWideIntType) {
	    i1 = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
	} else if (t1Ptr == &tclDoubleType) {
	    i1 = (valuePtr->internalRep.doubleValue != 0.0);
	} else {
	    s = Tcl_GetStringFromObj(valuePtr, &length);
	    if (TclLooksLikeInt(s, length)) {
#ifdef TCL_WIDE_INT_IS_LONG
		result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
					    valuePtr, &i);
		i1 = (i != 0);
#else /* !TCL_WIDE_INT_IS_LONG */
		GET_WIDE_OR_INT(result, valuePtr, i, w);
		if (valuePtr->typePtr == &tclIntType) {
		    i1 = (i != 0);
		} else {
		    i1 = (w != W0);
		}
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
					       valuePtr, &i1);
		i1 = (i1 != 0);
	    }
	    if (result != TCL_OK) {
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),

		        (t1Ptr? t1Ptr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);


		goto checkForCatch;
	    }
	}
		
	if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
	    i2 = (value2Ptr->internalRep.longValue != 0);
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (t2Ptr == &tclWideIntType) {
	    i2 = (value2Ptr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
	} else if (t2Ptr == &tclDoubleType) {
	    i2 = (value2Ptr->internalRep.doubleValue != 0.0);
	} else {
	    s = Tcl_GetStringFromObj(value2Ptr, &length);
	    if (TclLooksLikeInt(s, length)) {
#ifdef TCL_WIDE_INT_IS_LONG
		result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
					    value2Ptr, &i);
		i2 = (i != 0);
#else /* !TCL_WIDE_INT_IS_LONG */
		GET_WIDE_OR_INT(result, value2Ptr, i, w);
		if (value2Ptr->typePtr == &tclIntType) {
		    i2 = (i != 0);
		} else {
		    i2 = (w != W0);
		}
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);

	    }
	    if (result != TCL_OK) {
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),

		        (t2Ptr? t2Ptr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);


		goto checkForCatch;
	    }
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */
	
	if (*pc == INST_LOR) {
	    iResult = (i1 || i2);
	} else {
	    iResult = (i1 && i2);
	}
	if (Tcl_IsShared(valuePtr)) {
	    objResultPtr = Tcl_NewLongObj(iResult);
	    TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
	    NEXT_INST_F(1, 2, 1);

	} else {	/* reuse the valuePtr object */
	    TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));

	    Tcl_SetLongObj(valuePtr, iResult);

	    NEXT_INST_F(1, 1, 0);
	}
    }

    /*
     * ---------------------------------------------------------
     *     Start of INST_LIST and related instructions.
     */

    case INST_LIST:
	/*
	 * Pop the opnd (objc) top stack elements into a new list obj
	 * and then decrement their ref counts. 
	 */

	opnd = TclGetUInt4AtPtr(pc+1);
	objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
	TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
	NEXT_INST_V(5, opnd, 1);

    case INST_LIST_LENGTH:
	valuePtr = stackPtr[stackTop];

	result = Tcl_ListObjLength(interp, valuePtr, &length);
	if (result != TCL_OK) {
	    TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
	            Tcl_GetObjResult(interp));

	    goto checkForCatch;
	}
	objResultPtr = Tcl_NewIntObj(length);
	TRACE(("%.20s => %d\n", O2S(valuePtr), length));

	NEXT_INST_F(1, 1, 1);
	    
    case INST_LIST_INDEX:
	/*** lindex with objc == 3 ***/
		
	/*
	 * Pop the two operands
	 */
	value2Ptr = stackPtr[stackTop];
	valuePtr  = stackPtr[stackTop- 1];

	/*
	 * Extract the desired list element
	 */
	objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),

	            Tcl_GetObjResult(interp));


	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Stash the list element on the stack
	 */

	TRACE(("%.20s %.20s => %s\n",
	        O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
	NEXT_INST_F(1, 2, -1); /* already has the correct refCount */




    case INST_LIST_INDEX_MULTI:
    {
	/*
	 * 'lindex' with multiple index args:
	 *
	 * Determine the count of index args.
	 */

	int numIdx;

	opnd = TclGetUInt4AtPtr(pc+1);
	numIdx = opnd-1;

	/*
	 * Do the 'lindex' operation.
	 */
	objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
	        numIdx, stackPtr + stackTop - numIdx + 1);

	/*












	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));

	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */

	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));

	NEXT_INST_V(5, opnd, -1);
    }


    case INST_LSET_FLAT:
    {
	/*
	 * Lset with 3, 5, or more args.  Get the number
	 * of index args.
	 */
	int numIdx;

	opnd = TclGetUInt4AtPtr( pc + 1 );
	numIdx = opnd - 2;

	/*
	 * Get the old value of variable, and remove the stack ref.
	 * This is safe because the variable still references the
	 * object; the ref count will never go zero here.
	 */
	value2Ptr = POP_OBJECT();
	TclDecrRefCount(value2Ptr); /* This one should be done here */

	/*
	 * Get the new element value.
	 */
	valuePtr = stackPtr[stackTop];

	/*
	 * Compute the new variable value
	 */
	objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
	        stackPtr + stackTop - numIdx, valuePtr);














	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));

	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */

	TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));

	NEXT_INST_V(5, (numIdx+1), -1);
    }


    case INST_LSET_LIST:
	/*
	 * 'lset' with 4 args.
	 *
	 * Get the old value of variable, and remove the stack ref.
	 * This is safe because the variable still references the
	 * object; the ref count will never go zero here.
	 */
	objPtr = POP_OBJECT(); 
	TclDecrRefCount(objPtr); /* This one should be done here */
	
	/*
	 * Get the new element value, and the index list
	 */
	valuePtr = stackPtr[stackTop];
	value2Ptr = stackPtr[stackTop - 1];
	
	/*
	 * Compute the new variable value
	 */
	objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);



	/*
	 * Check for errors
	 */
	if (objResultPtr == NULL) {
	    TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
	            Tcl_GetObjResult(interp));
	    result = TCL_ERROR;
	    goto checkForCatch;
	}

	/*
	 * Set result
	 */

	TRACE(("=> %s\n", O2S(objResultPtr)));
	NEXT_INST_F(1, 2, -1);

    /*
     *     End of INST_LIST and related instructions.
     * ---------------------------------------------------------
     */

    case INST_STR_EQ:
    case INST_STR_NEQ:
    {
	/*
	 * String (in)equality check
	 */
	int iResult;

	value2Ptr = stackPtr[stackTop];
	valuePtr = stackPtr[stackTop - 1];

	if (valuePtr == value2Ptr) {
	    /*
	     * On the off-chance that the objects are the same,
	     * we don't really have to think hard about equality.
	     */
	    iResult = (*pc == INST_STR_EQ);
	} else {
	    char *s1, *s2;
	    int s1len, s2len;

	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    if (s1len == s2len) {
		/*
		 * We only need to check (in)equality when
		 * we have equal length strings.
		 */
		if (*pc == INST_STR_NEQ) {
		    iResult = (strcmp(s1, s2) != 0);
		} else {
		    /* INST_STR_EQ */
		    iResult = (strcmp(s1, s2) == 0);
		}
	    } else {
		iResult = (*pc == INST_STR_NEQ);
	    }
	}


	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump
	 * from here.
	 */

	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	    case INST_JUMP_FALSE1:
		NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE1:
		NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	    case INST_JUMP_FALSE4:
		NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE4:
		NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}
#endif
	objResultPtr = Tcl_NewIntObj(iResult);
	NEXT_INST_F(0, 2, 1);
    }

    case INST_STR_CMP:
    {
	/*
	 * String compare
	 */
	CONST char *s1, *s2;
	int s1len, s2len, iResult;

	value2Ptr = stackPtr[stackTop];
	valuePtr = stackPtr[stackTop - 1];

	/*
	 * The comparison function should compare up to the
	 * minimum byte length only.
	 */
	if (valuePtr == value2Ptr) {
	    /*
	     * In the pure equality case, set lengths too for
	     * the checks below (or we could goto beyond it).
	     */
	    iResult = s1len = s2len = 0;
	} else if ((valuePtr->typePtr == &tclByteArrayType)
	        && (value2Ptr->typePtr == &tclByteArrayType)) {
	    s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
	    s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
	    iResult = memcmp(s1, s2, 
	            (size_t) ((s1len < s2len) ? s1len : s2len));
	} else if (((valuePtr->typePtr == &tclStringType)
	        && (value2Ptr->typePtr == &tclStringType))) {
	    /*
	     * Do a unicode-specific comparison if both of the args
	     * are of String type.  In benchmark testing this proved
	     * the most efficient check between the unicode and
	     * string comparison operations.
	     */
	    Tcl_UniChar *uni1, *uni2;
	    uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len);
	    uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
	    iResult = TclUniCharNcmp(uni1, uni2,
				     (unsigned) ((s1len < s2len) ? s1len : s2len));
	} else {
	    /*
	     * We can't do a simple memcmp in order to handle the
	     * special Tcl \xC0\x80 null encoding for utf-8.
	     */
	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    iResult = TclpUtfNcmp2(s1, s2,
	            (size_t) ((s1len < s2len) ? s1len : s2len));
	}

	/*
	 * Make sure only -1,0,1 is returned
	 */
	if (iResult == 0) {
	    iResult = s1len - s2len;
	}
	if (iResult < 0) {
	    iResult = -1;
	} else if (iResult > 0) {
	    iResult = 1;
	}

	objResultPtr = Tcl_NewIntObj(iResult);
	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
	NEXT_INST_F(1, 2, 1);


    }


    case INST_STR_LEN:
    {
	int length1;
		 
	valuePtr = stackPtr[stackTop];

	if (valuePtr->typePtr == &tclByteArrayType) {
	    (void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
	} else {
	    length1 = Tcl_GetCharLength(valuePtr);
	}
	objResultPtr = Tcl_NewIntObj(length1);
	TRACE(("%.20s => %d\n", O2S(valuePtr), length1));

	NEXT_INST_F(1, 1, 1);
    }

	    
    case INST_STR_INDEX:
    {
	/*
	 * String compare
	 */
	int index;
	bytes = NULL; /* lint */

	value2Ptr = stackPtr[stackTop];
	valuePtr = stackPtr[stackTop - 1];

	/*
	 * If we have a ByteArray object, avoid indexing in the
	 * Utf string since the byte array contains one byte per
	 * character.  Otherwise, use the Unicode string rep to
	 * get the index'th char.
	 */

	if (valuePtr->typePtr == &tclByteArrayType) {
	    bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
	} else {
	    /*
	     * Get Unicode char length to calulate what 'end' means.
	     */
	    length = Tcl_GetCharLength(valuePtr);
	}

	result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);

	if (result != TCL_OK) {


	    goto checkForCatch;
	}

	if ((index >= 0) && (index < length)) {
	    if (valuePtr->typePtr == &tclByteArrayType) {
		objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
		        (&bytes[index]), 1);
	    } else {
		char buf[TCL_UTF_MAX];
		Tcl_UniChar ch;

		ch = Tcl_GetUniChar(valuePtr, index);
		/*
		 * This could be:
		 * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
		 * but creating the object as a string seems to be
		 * faster in practical use.
		 */
		length = Tcl_UniCharToUtf(ch, buf);
		objResultPtr = Tcl_NewStringObj(buf, length);
	    }
	} else {
	    TclNewObj(objResultPtr);
	}


	TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), 
	        O2S(objResultPtr)));


	NEXT_INST_F(1, 2, 1);
    }


    case INST_STR_MATCH:
    {
	int nocase, match;

	nocase    = TclGetInt1AtPtr(pc+1);
	valuePtr  = stackPtr[stackTop];	        /* String */
	value2Ptr = stackPtr[stackTop - 1];	/* Pattern */

	/*
	 * Check that at least one of the objects is Unicode before
	 * promoting both.
	 */
	if ((valuePtr->typePtr == &tclStringType)
	        || (value2Ptr->typePtr == &tclStringType)) {
	    match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr),
	            Tcl_GetUnicode(value2Ptr), nocase);
	} else {
	    match = Tcl_StringCaseMatch(TclGetString(valuePtr),
		    TclGetString(value2Ptr), nocase);
	}

	/*
	 * Reuse value2Ptr object already on stack if possible.
	 * Adjustment is 2 due to the nocase byte
	 */

	TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));


	if (Tcl_IsShared(value2Ptr)) {
	    objResultPtr = Tcl_NewIntObj(match);

	    NEXT_INST_F(2, 2, 1);
	} else {	/* reuse the valuePtr object */
	    Tcl_SetIntObj(value2Ptr, match);

	    NEXT_INST_F(2, 1, 0);
	}
    }





    case INST_EQ:
    case INST_NEQ:
    case INST_LT:
    case INST_GT:
    case INST_LE:
    case INST_GE:
    {
	/*
	 * Any type is allowed but the two operands must have the
	 * same type. We will compute value op value2.
	 */

	Tcl_ObjType *t1Ptr, *t2Ptr;
	char *s1 = NULL;	/* Init. avoids compiler warning. */
	char *s2 = NULL;	/* Init. avoids compiler warning. */
	long i2 = 0;		/* Init. avoids compiler warning. */
	double d1 = 0.0;	/* Init. avoids compiler warning. */
	double d2 = 0.0;	/* Init. avoids compiler warning. */
	long iResult = 0;	/* Init. avoids compiler warning. */

	value2Ptr = stackPtr[stackTop];
	valuePtr  = stackPtr[stackTop - 1];

	if (valuePtr == value2Ptr) {
	    /*
	     * Optimize the equal object case.
	     */
	    switch (*pc) {
	        case INST_EQ:
	        case INST_LE:
	        case INST_GE:
		    iResult = 1;
		    break;
	        case INST_NEQ:
	        case INST_LT:
	        case INST_GT:
		    iResult = 0;
		    break;
	    }
	    goto foundResult;
	}

	t1Ptr = valuePtr->typePtr;
	t2Ptr = value2Ptr->typePtr;

	/*
	 * We only want to coerce numeric validation if neither type
	 * is NULL.  A NULL type means the arg is essentially an empty
	 * object ("", {} or [list]).
	 */
	if (!(     (!t1Ptr && !valuePtr->bytes)
	        || (valuePtr->bytes && !valuePtr->length)
		   || (!t2Ptr && !value2Ptr->bytes)
		   || (value2Ptr->bytes && !value2Ptr->length))) {
	    if (!IS_NUMERIC_TYPE(t1Ptr)) {
		s1 = Tcl_GetStringFromObj(valuePtr, &length);
		if (TclLooksLikeInt(s1, length)) {
		    GET_WIDE_OR_INT(iResult, valuePtr, i, w);
		} else {
		    (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, 
		            valuePtr, &d1);
		}
		t1Ptr = valuePtr->typePtr;
	    }
	    if (!IS_NUMERIC_TYPE(t2Ptr)) {
		s2 = Tcl_GetStringFromObj(value2Ptr, &length);
		if (TclLooksLikeInt(s2, length)) {
		    GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
		} else {
		    (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		            value2Ptr, &d2);
		}
		t2Ptr = value2Ptr->typePtr;
	    }
	}
	if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
	    /*
	     * One operand is not numeric. Compare as strings.  NOTE:
	     * strcmp is not correct for \x00 < \x01, but that is
	     * unlikely to occur here.  We could use the TclUtfNCmp2
	     * to handle this.
	     */
	    int s1len, s2len;
	    s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
	    s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
	    switch (*pc) {
	        case INST_EQ:
		    if (s1len == s2len) {
			iResult = (strcmp(s1, s2) == 0);
		    } else {
			iResult = 0;
		    }
		    break;
	        case INST_NEQ:
		    if (s1len == s2len) {
			iResult = (strcmp(s1, s2) != 0);
		    } else {
			iResult = 1;
		    }
		    break;
	        case INST_LT:
		    iResult = (strcmp(s1, s2) < 0);
		    break;
	        case INST_GT:
		    iResult = (strcmp(s1, s2) > 0);
		    break;
	        case INST_LE:
		    iResult = (strcmp(s1, s2) <= 0);
		    break;
	        case INST_GE:
		    iResult = (strcmp(s1, s2) >= 0);
		    break;
	    }
	} else if ((t1Ptr == &tclDoubleType)
		   || (t2Ptr == &tclDoubleType)) {
	    /*
	     * Compare as doubles.
	     */
	    if (t1Ptr == &tclDoubleType) {
		d1 = valuePtr->internalRep.doubleValue;
		GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
	    } else {	/* t1Ptr is integer, t2Ptr is double */
		GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
		d2 = value2Ptr->internalRep.doubleValue;
	    }
	    switch (*pc) {
	        case INST_EQ:
		    iResult = d1 == d2;
		    break;
	        case INST_NEQ:
		    iResult = d1 != d2;
		    break;
	        case INST_LT:
		    iResult = d1 < d2;
		    break;
	        case INST_GT:
		    iResult = d1 > d2;
		    break;
	        case INST_LE:
		    iResult = d1 <= d2;
		    break;
	        case INST_GE:
		    iResult = d1 >= d2;
		    break;
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	} else if ((t1Ptr == &tclWideIntType)
	        || (t2Ptr == &tclWideIntType)) {
	    Tcl_WideInt w2;
	    /*
	     * Compare as wide ints (neither are doubles)
	     */
	    if (t1Ptr == &tclIntType) {
		w  = Tcl_LongAsWide(valuePtr->internalRep.longValue);
		w2 = value2Ptr->internalRep.wideValue;
	    } else if (t2Ptr == &tclIntType) {
		w  = valuePtr->internalRep.wideValue;
		w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
	    } else {
		w  = valuePtr->internalRep.wideValue;
		w2 = value2Ptr->internalRep.wideValue;
	    }
	    switch (*pc) {
	        case INST_EQ:
		    iResult = w == w2;
		    break;
	        case INST_NEQ:
		    iResult = w != w2;
		    break;
	        case INST_LT:
		    iResult = w < w2;
		    break;
	        case INST_GT:
		    iResult = w > w2;
		    break;
	        case INST_LE:
		    iResult = w <= w2;
		    break;
	        case INST_GE:
		    iResult = w >= w2;
		    break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	} else {
	    /*
	     * Compare as ints.
	     */
	    i  = valuePtr->internalRep.longValue;
	    i2 = value2Ptr->internalRep.longValue;
	    switch (*pc) {
	        case INST_EQ:
		    iResult = i == i2;
		    break;
	        case INST_NEQ:
		    iResult = i != i2;
		    break;
	        case INST_LT:
		    iResult = i < i2;
		    break;
	        case INST_GT:
		    iResult = i > i2;
		    break;
	        case INST_LE:
		    iResult = i <= i2;
		    break;
	        case INST_GE:
		    iResult = i >= i2;
		    break;
	    }
	}




    foundResult:
	TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));

	/*
	 * Peep-hole optimisation: if you're about to jump, do jump
	 * from here.
	 */

	pc++;
#ifndef TCL_COMPILE_DEBUG
	switch (*pc) {
	    case INST_JUMP_FALSE1:
		NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);

	    case INST_JUMP_TRUE1:
		NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
	    case INST_JUMP_FALSE4:
		NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
	    case INST_JUMP_TRUE4:
		NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
	}

#endif
	objResultPtr = Tcl_NewIntObj(iResult);
	NEXT_INST_F(0, 2, 1);
    }


    case INST_MOD:
    case INST_LSHIFT:
    case INST_RSHIFT:
    case INST_BITOR:
    case INST_BITXOR:
    case INST_BITAND:
    {
	/*
	 * Only integers are allowed. We compute value op value2.
	 */

	long i2 = 0, rem, negative;
	long iResult = 0; /* Init. avoids compiler warning. */
#ifndef TCL_WIDE_INT_IS_LONG
	Tcl_WideInt w2, wResult = W0;
	int doWide = 0;
#endif /* TCL_WIDE_INT_IS_LONG */

	value2Ptr = stackPtr[stackTop];
	valuePtr  = stackPtr[stackTop - 1]; 
	if (valuePtr->typePtr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    w = valuePtr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
	} else {	/* try to convert to int */
	    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
		        O2S(valuePtr), O2S(value2Ptr), 
		        (valuePtr->typePtr? 
			     valuePtr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);


		goto checkForCatch;
	    }
	}
	if (value2Ptr->typePtr == &tclIntType) {
	    i2 = value2Ptr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (value2Ptr->typePtr == &tclWideIntType) {
	    w2 = value2Ptr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
	} else {
	    REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
		        O2S(valuePtr), O2S(value2Ptr),
		        (value2Ptr->typePtr?
			    value2Ptr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);


		goto checkForCatch;
	    }
	}

	switch (*pc) {
	case INST_MOD:
	    /*
	     * This code is tricky: C doesn't guarantee much about
	     * the quotient or remainder, but Tcl does. The
	     * remainder always has the same sign as the divisor and
	     * a smaller absolute value.
	     */
#ifdef TCL_WIDE_INT_IS_LONG
	    if (i2 == 0) {
		TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));


		goto divideByZero;
	    }
#else /* !TCL_WIDE_INT_IS_LONG */
	    if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
		if (valuePtr->typePtr == &tclIntType) {
		    LLTRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
		} else {
		    LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
		}


		goto divideByZero;
	    }
	    if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
		if (valuePtr->typePtr == &tclIntType) {
		    TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
		} else {
		    LLTRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
		}


		goto divideByZero;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    negative = 0;
#ifndef TCL_WIDE_INT_IS_LONG
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		Tcl_WideInt wRemainder;
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		if (w2 < 0) {
		    w2 = -w2;
		    w = -w;
		    negative = 1;
		}
		wRemainder  = w % w2;
		if (wRemainder < 0) {
		    wRemainder += w2;
		}
		if (negative) {
		    wRemainder = -wRemainder;
		}
		wResult = wRemainder;
		doWide = 1;
		break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    if (i2 < 0) {
		i2 = -i2;
		i = -i;
		negative = 1;
	    }
	    rem  = i % i2;
	    if (rem < 0) {
		rem += i2;
	    }
	    if (negative) {
		rem = -rem;
	    }
	    iResult = rem;
	    break;
	case INST_LSHIFT:
#ifndef TCL_WIDE_INT_IS_LONG
	    /*
	     * Shifts are never usefully 64-bits wide!
	     */
	    FORCE_LONG(value2Ptr, i2, w2);
	    if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
		w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
		wResult = w << i2;
		doWide = 1;
		break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    iResult = i << i2;
	    break;
	case INST_RSHIFT:
	    /*
	     * The following code is a bit tricky: it ensures that
	     * right shifts propagate the sign bit even on machines
	     * where ">>" won't do it by default.
	     */
#ifndef TCL_WIDE_INT_IS_LONG
	    /*
	     * Shifts are never usefully 64-bits wide!
	     */
	    FORCE_LONG(value2Ptr, i2, w2);
	    if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
		w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
		if (w < 0) {
		    wResult = ~((~w) >> i2);
		} else {
		    wResult = w >> i2;
		}
		doWide = 1;
		break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    if (i < 0) {
		iResult = ~((~i) >> i2);
	    } else {
		iResult = i >> i2;
	    }
	    break;
	case INST_BITOR:
#ifndef TCL_WIDE_INT_IS_LONG
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		wResult = w | w2;
		doWide = 1;
		break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    iResult = i | i2;
	    break;
	case INST_BITXOR:
#ifndef TCL_WIDE_INT_IS_LONG
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		wResult = w ^ w2;
		doWide = 1;
		break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    iResult = i ^ i2;
	    break;
	case INST_BITAND:
#ifndef TCL_WIDE_INT_IS_LONG
	    if (valuePtr->typePtr == &tclWideIntType
		|| value2Ptr->typePtr == &tclWideIntType) {
		/*
		 * Promote to wide
		 */
		if (valuePtr->typePtr == &tclIntType) {
		    w = Tcl_LongAsWide(i);
		} else if (value2Ptr->typePtr == &tclIntType) {
		    w2 = Tcl_LongAsWide(i2);
		}
		wResult = w & w2;
		doWide = 1;
		break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    iResult = i & i2;
	    break;
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */
		
	if (Tcl_IsShared(valuePtr)) {
#ifndef TCL_WIDE_INT_IS_LONG
	    if (doWide) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
	    } else {
#endif /* TCL_WIDE_INT_IS_LONG */
		objResultPtr = Tcl_NewLongObj(iResult);
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
#ifndef TCL_WIDE_INT_IS_LONG
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    NEXT_INST_F(1, 2, 1);
	} else {	/* reuse the valuePtr object */
#ifndef TCL_WIDE_INT_IS_LONG
	    if (doWide) {
		LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		Tcl_SetWideIntObj(valuePtr, wResult);
	    } else {
#endif /* TCL_WIDE_INT_IS_LONG */
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		Tcl_SetLongObj(valuePtr, iResult);
#ifndef TCL_WIDE_INT_IS_LONG
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    NEXT_INST_F(1, 1, 0);
	}

    }


    case INST_ADD:
    case INST_SUB:
    case INST_MULT:
    case INST_DIV:
    {
	/*
	 * Operands must be numeric and ints get converted to floats
	 * if necessary. We compute value op value2.
	 */

	Tcl_ObjType *t1Ptr, *t2Ptr;
	long i2 = 0, quot, rem;	/* Init. avoids compiler warning. */
	double d1, d2;
	long iResult = 0;	/* Init. avoids compiler warning. */
	double dResult = 0.0;	/* Init. avoids compiler warning. */
	int doDouble = 0;	/* 1 if doing floating arithmetic */
#ifndef TCL_WIDE_INT_IS_LONG
	Tcl_WideInt w2, wquot, wrem;
	Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
	int doWide = 0;		/* 1 if doing wide arithmetic. */
#endif /* TCL_WIDE_INT_IS_LONG */

	value2Ptr = stackPtr[stackTop];
	valuePtr  = stackPtr[stackTop - 1];
	t1Ptr = valuePtr->typePtr;
	t2Ptr = value2Ptr->typePtr;
		
	if (t1Ptr == &tclIntType) {
	    i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (t1Ptr == &tclWideIntType) {
	    w = valuePtr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
	} else if ((t1Ptr == &tclDoubleType)
		   && (valuePtr->bytes == NULL)) {
	    /*
	     * We can only use the internal rep directly if there is
	     * no string rep.  Otherwise the string rep might actually
	     * look like an integer, which is preferred.
	     */

	    d1 = valuePtr->internalRep.doubleValue;
	} else {
	    char *s = Tcl_GetStringFromObj(valuePtr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, valuePtr, i, w);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
					      valuePtr, &d1);
	    }
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
		        s, O2S(valuePtr),
		        (valuePtr->typePtr?
			    valuePtr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);


		goto checkForCatch;
	    }
	    t1Ptr = valuePtr->typePtr;
	}

	if (t2Ptr == &tclIntType) {
	    i2 = value2Ptr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (t2Ptr == &tclWideIntType) {
	    w2 = value2Ptr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
	} else if ((t2Ptr == &tclDoubleType)
		   && (value2Ptr->bytes == NULL)) {
	    /*
	     * We can only use the internal rep directly if there is
	     * no string rep.  Otherwise the string rep might actually
	     * look like an integer, which is preferred.
	     */

	    d2 = value2Ptr->internalRep.doubleValue;
	} else {
	    char *s = Tcl_GetStringFromObj(value2Ptr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		        value2Ptr, &d2);
	    }
	    if (result != TCL_OK) {
		TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
		        O2S(value2Ptr), s,
		        (value2Ptr->typePtr?
			    value2Ptr->typePtr->name : "null")));
		IllegalExprOperandType(interp, pc, value2Ptr);


		goto checkForCatch;
	    }
	    t2Ptr = value2Ptr->typePtr;
	}

	if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
	    /*
	     * Do double arithmetic.
	     */
	    doDouble = 1;
	    if (t1Ptr == &tclIntType) {
		d1 = i;       /* promote value 1 to double */
	    } else if (t2Ptr == &tclIntType) {
		d2 = i2;      /* promote value 2 to double */
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (t1Ptr == &tclWideIntType) {
		d1 = Tcl_WideAsDouble(w);
	    } else if (t2Ptr == &tclWideIntType) {
		d2 = Tcl_WideAsDouble(w2);
#endif /* TCL_WIDE_INT_IS_LONG */
	    }
	    switch (*pc) {
	        case INST_ADD:
		    dResult = d1 + d2;
		    break;
	        case INST_SUB:
		    dResult = d1 - d2;
		    break;
	        case INST_MULT:
		    dResult = d1 * d2;
		    break;
	        case INST_DIV:
		    if (d2 == 0.0) {
			TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));


			goto divideByZero;
		    }
		    dResult = d1 / d2;
		    break;
	    }
		    
	    /*
	     * Check now for IEEE floating-point error.
	     */
		    
	    if (IS_NAN(dResult) || IS_INF(dResult)) {
		TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
		        O2S(valuePtr), O2S(value2Ptr)));
		TclExprFloatError(interp, dResult);
		result = TCL_ERROR;


		goto checkForCatch;
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	} else if ((t1Ptr == &tclWideIntType) 
		   || (t2Ptr == &tclWideIntType)) {
	    /*
	     * Do wide integer arithmetic.
	     */
	    doWide = 1;
	    if (t1Ptr == &tclIntType) {
		w = Tcl_LongAsWide(i);
	    } else if (t2Ptr == &tclIntType) {
		w2 = Tcl_LongAsWide(i2);
	    }
	    switch (*pc) {
	        case INST_ADD:
		    wResult = w + w2;
		    break;
	        case INST_SUB:
		    wResult = w - w2;
		    break;
	        case INST_MULT:
		    wResult = w * w2;
		    break;
	        case INST_DIV:
		    /*
		     * This code is tricky: C doesn't guarantee much
		     * about the quotient or remainder, but Tcl does.
		     * The remainder always has the same sign as the
		     * divisor and a smaller absolute value.
		     */
		    if (w2 == W0) {
			LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));


			goto divideByZero;
		    }
		    if (w2 < 0) {
			w2 = -w2;
			w = -w;
		    }
		    wquot = w / w2;
		    wrem  = w % w2;
		    if (wrem < W0) {
			wquot -= 1;
		    }
		    wResult = wquot;
		    break;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	} else {
	    /*
		     * Do integer arithmetic.
		     */
	    switch (*pc) {
	        case INST_ADD:
		    iResult = i + i2;
		    break;
	        case INST_SUB:
		    iResult = i - i2;
		    break;
	        case INST_MULT:
		    iResult = i * i2;
		    break;
	        case INST_DIV:
		    /*
		     * This code is tricky: C doesn't guarantee much
		     * about the quotient or remainder, but Tcl does.
		     * The remainder always has the same sign as the
		     * divisor and a smaller absolute value.
		     */
		    if (i2 == 0) {
			TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));


			goto divideByZero;
		    }
		    if (i2 < 0) {
			i2 = -i2;
			i = -i;
		    }
		    quot = i / i2;
		    rem  = i % i2;
		    if (rem < 0) {
			quot -= 1;
		    }
		    iResult = quot;
		    break;
	    }
	}

	/*
	 * Reuse the valuePtr object already on stack if possible.
	 */
		
	if (Tcl_IsShared(valuePtr)) {
	    if (doDouble) {
		objResultPtr = Tcl_NewDoubleObj(dResult);
		TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (doWide) {
		objResultPtr = Tcl_NewWideIntObj(wResult);
		LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		objResultPtr = Tcl_NewLongObj(iResult);
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
	    } 
	    NEXT_INST_F(1, 2, 1);
	} else {	    /* reuse the valuePtr object */
	    if (doDouble) { /* NB: stack top is off by 1 */
		TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
		Tcl_SetDoubleObj(valuePtr, dResult);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (doWide) {
		LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
		Tcl_SetWideIntObj(valuePtr, wResult);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		TRACE(("%ld %ld => %ld\n", i, i2, iResult));
		Tcl_SetLongObj(valuePtr, iResult);
	    }
	    NEXT_INST_F(1, 1, 0);
	}

    }


    case INST_UPLUS:
    {
	/*
	 * Operand must be numeric.
	 */

	double d;
	Tcl_ObjType *tPtr;
		
	valuePtr = stackPtr[stackTop];
	tPtr = valuePtr->typePtr;
	if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) 
                || (valuePtr->bytes != NULL))) {
	    char *s = Tcl_GetStringFromObj(valuePtr, &length);
	    if (TclLooksLikeInt(s, length)) {
		GET_WIDE_OR_INT(result, valuePtr, i, w);
	    } else {
		result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);

	    }
	    if (result != TCL_OK) { 
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
		        s, (tPtr? tPtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);
		goto checkForCatch;
	    }
	    tPtr = valuePtr->typePtr;
	}

	/*
	 * Ensure that the operand's string rep is the same as the
	 * formatted version of its internal rep. This makes sure
	 * that "expr +000123" yields "83", not "000123". We
	 * implement this by _discarding_ the string rep since we
	 * know it will be regenerated, if needed later, by
	 * formatting the internal rep's value.
	 */

	if (Tcl_IsShared(valuePtr)) {
	    if (tPtr == &tclIntType) {
		i = valuePtr->internalRep.longValue;
		objResultPtr = Tcl_NewLongObj(i);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (tPtr == &tclWideIntType) {
		w = valuePtr->internalRep.wideValue;
		objResultPtr = Tcl_NewWideIntObj(w);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		d = valuePtr->internalRep.doubleValue;
		objResultPtr = Tcl_NewDoubleObj(d);
	    }
	    TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
	    NEXT_INST_F(1, 1, 1);


	} else {
	    Tcl_InvalidateStringRep(valuePtr);

	    TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
	    NEXT_INST_F(1, 0, 0);
	}

    }
	    
    case INST_UMINUS:
    case INST_LNOT:
    {
	/*
	 * The operand must be numeric or a boolean string as
	 * accepted by Tcl_GetBooleanFromObj(). If the operand
	 * object is unshared modify it directly, otherwise
	 * create a copy to modify: this is "copy on write".
	 * Free any old string representation since it is now
	 * invalid.
	 */

	double d;
	int boolvar;
	Tcl_ObjType *tPtr;

	valuePtr = stackPtr[stackTop];
	tPtr = valuePtr->typePtr;
	if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
	        || (valuePtr->bytes != NULL))) {
	    if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {

		valuePtr->typePtr = &tclIntType;
	    } else {
		char *s = Tcl_GetStringFromObj(valuePtr, &length);
		if (TclLooksLikeInt(s, length)) {
		    GET_WIDE_OR_INT(result, valuePtr, i, w);
		} else {
		    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		            valuePtr, &d);
		}
		if (result == TCL_ERROR && *pc == INST_LNOT) {
		    result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
		            valuePtr, &boolvar);
		    i = (long)boolvar; /* i is long, not int! */
		}
		if (result != TCL_OK) {
		    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
		            s, (tPtr? tPtr->name : "null")));
		    IllegalExprOperandType(interp, pc, valuePtr);

		    goto checkForCatch;
		}
	    }
	    tPtr = valuePtr->typePtr;
	}

	if (Tcl_IsShared(valuePtr)) {
	    /*
	     * Create a new object.
	     */
	    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
		i = valuePtr->internalRep.longValue;
		objResultPtr = Tcl_NewLongObj(
		    (*pc == INST_UMINUS)? -i : !i);
		TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (tPtr == &tclWideIntType) {
		w = valuePtr->internalRep.wideValue;
		if (*pc == INST_UMINUS) {
		    objResultPtr = Tcl_NewWideIntObj(-w);
		} else {
		    objResultPtr = Tcl_NewLongObj(w == W0);
		}
		LLTRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		d = valuePtr->internalRep.doubleValue;
		if (*pc == INST_UMINUS) {
		    objResultPtr = Tcl_NewDoubleObj(-d);
		} else {
		    /*
		     * Should be able to use "!d", but apparently
		     * some compilers can't handle it.
		     */
		    objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
		}
		TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
	    }
	    NEXT_INST_F(1, 1, 1);

	} else {
	    /*
	     * valuePtr is unshared. Modify it directly.
	     */
	    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
		i = valuePtr->internalRep.longValue;
		Tcl_SetLongObj(valuePtr,
	                (*pc == INST_UMINUS)? -i : !i);
		TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (tPtr == &tclWideIntType) {
		w = valuePtr->internalRep.wideValue;
		if (*pc == INST_UMINUS) {
		    Tcl_SetWideIntObj(valuePtr, -w);
		} else {
		    Tcl_SetLongObj(valuePtr, w == W0);
		}
		LLTRACE_WITH_OBJ((LLD" => ", w), valuePtr);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		d = valuePtr->internalRep.doubleValue;
		if (*pc == INST_UMINUS) {
		    Tcl_SetDoubleObj(valuePtr, -d);
		} else {
		    /*
		     * Should be able to use "!d", but apparently
		     * some compilers can't handle it.
		     */
		    Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
		}
		TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
	    }
	    NEXT_INST_F(1, 0, 0);
	}
    }


    case INST_BITNOT:
    {
	/*
	 * The operand must be an integer. If the operand object is
	 * unshared modify it directly, otherwise modify a copy. 
	 * Free any old string representation since it is now
	 * invalid.
	 */
		
	Tcl_ObjType *tPtr;
		
	valuePtr = stackPtr[stackTop];
	tPtr = valuePtr->typePtr;
	if (!IS_INTEGER_TYPE(tPtr)) {
	    REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
	    if (result != TCL_OK) {   /* try to convert to double */
		TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
		        O2S(valuePtr), (tPtr? tPtr->name : "null")));
		IllegalExprOperandType(interp, pc, valuePtr);

		goto checkForCatch;
	    }
	}
		
#ifndef TCL_WIDE_INT_IS_LONG
	if (valuePtr->typePtr == &tclWideIntType) {
	    w = valuePtr->internalRep.wideValue;
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewWideIntObj(~w);
		LLTRACE(("0x%llx => (%llu)\n", w, ~w));
		NEXT_INST_F(1, 1, 1);
	    } else {
		/*
		 * valuePtr is unshared. Modify it directly.
		 */
		Tcl_SetWideIntObj(valuePtr, ~w);

		LLTRACE(("0x%llx => (%llu)\n", w, ~w));
		NEXT_INST_F(1, 0, 0);
	    }
	} else {
#endif /* TCL_WIDE_INT_IS_LONG */
	    i = valuePtr->internalRep.longValue;
	    if (Tcl_IsShared(valuePtr)) {
		objResultPtr = Tcl_NewLongObj(~i);
		TRACE(("0x%lx => (%lu)\n", i, ~i));
		NEXT_INST_F(1, 1, 1);
	    } else {
		/*
		 * valuePtr is unshared. Modify it directly.
		 */
		Tcl_SetLongObj(valuePtr, ~i);

		TRACE(("0x%lx => (%lu)\n", i, ~i));
		NEXT_INST_F(1, 0, 0);
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	}
#endif /* TCL_WIDE_INT_IS_LONG */
    }


    case INST_CALL_BUILTIN_FUNC1:
	opnd = TclGetUInt1AtPtr(pc+1);
	{
	    /*
	     * Call one of the built-in Tcl math functions.
	     */

	    BuiltinFunc *mathFuncPtr;

	    if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
		TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
		panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
	    }
	    mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
	    DECACHE_STACK_INFO();
	    result = (*mathFuncPtr->proc)(interp, eePtr,
	            mathFuncPtr->clientData);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		goto checkForCatch;
	    }
	    TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
	}
	NEXT_INST_F(2, 0, 0);
		    
    case INST_CALL_FUNC1:
	opnd = TclGetUInt1AtPtr(pc+1);
	{
	    /*
	     * Call a non-builtin Tcl math function previously
	     * registered by a call to Tcl_CreateMathFunc.
	     */
		
	    int objc = opnd;   /* Number of arguments. The function name
				* is the 0-th argument. */
	    Tcl_Obj **objv;    /* The array of arguments. The function
				* name is objv[0]. */

	    objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
	    DECACHE_STACK_INFO();
	    result = ExprCallMathFunc(interp, eePtr, objc, objv);
	    CACHE_STACK_INFO();
	    if (result != TCL_OK) {
		goto checkForCatch;
	    }
	    TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);

	}
	NEXT_INST_F(2, 0, 0);

    case INST_TRY_CVT_TO_NUMERIC:
    {
	/*
	 * Try to convert the topmost stack object to an int or
	 * double object. This is done in order to support Tcl's
	 * policy of interpreting operands if at all possible as
	 * first integers, else floating-point numbers.
	 */
		
	double d;
	char *s;
	Tcl_ObjType *tPtr;
	int converted, needNew;

	valuePtr = stackPtr[stackTop];
	tPtr = valuePtr->typePtr;
	converted = 0;
	if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
	        || (valuePtr->bytes != NULL))) {
	    if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {

		valuePtr->typePtr = &tclIntType;
		converted = 1;
	    } else {
		s = Tcl_GetStringFromObj(valuePtr, &length);
		if (TclLooksLikeInt(s, length)) {
		    GET_WIDE_OR_INT(result, valuePtr, i, w);
		} else {
		    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
		            valuePtr, &d);
		}
		if (result == TCL_OK) {
		    converted = 1;
		}
		result = TCL_OK; /* reset the result variable */
	    }
	    tPtr = valuePtr->typePtr;
	}

	/*
	 * Ensure that the topmost stack object, if numeric, has a
	 * string rep the same as the formatted version of its
	 * internal rep. This is used, e.g., to make sure that "expr
	 * {0001}" yields "1", not "0001". We implement this by
	 * _discarding_ the string rep since we know it will be
	 * regenerated, if needed later, by formatting the internal
	 * rep's value. Also check if there has been an IEEE
	 * floating point error.
	 */
	
	objResultPtr = valuePtr;
	needNew = 0;
	if (IS_NUMERIC_TYPE(tPtr)) {

	    if (Tcl_IsShared(valuePtr)) {

		if (valuePtr->bytes != NULL) {
		    /*
		     * We only need to make a copy of the object
		     * when it already had a string rep
		     */
		    needNew = 1;
		    if (tPtr == &tclIntType) {
			i = valuePtr->internalRep.longValue;
			objResultPtr = Tcl_NewLongObj(i);
#ifndef TCL_WIDE_INT_IS_LONG
		    } else if (tPtr == &tclWideIntType) {
			w = valuePtr->internalRep.wideValue;
			objResultPtr = Tcl_NewWideIntObj(w);
#endif /* TCL_WIDE_INT_IS_LONG */
		    } else {
			d = valuePtr->internalRep.doubleValue;
			objResultPtr = Tcl_NewDoubleObj(d);
		    }


		    tPtr = objResultPtr->typePtr;


		}
	    } else {
		Tcl_InvalidateStringRep(valuePtr);
	    }
		
	    if (tPtr == &tclDoubleType) {
		d = objResultPtr->internalRep.doubleValue;
		if (IS_NAN(d) || IS_INF(d)) {
		    TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
		            O2S(objResultPtr)));
		    TclExprFloatError(interp, d);
		    result = TCL_ERROR;
		    goto checkForCatch;
		}
	    }

	    converted = converted;  /* lint, converted not used. */
	    TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
	            (converted? "converted" : "not converted"),

		    (needNew? "new Tcl_Obj" : "same Tcl_Obj")));
	} else {
	    TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
	}


	if (needNew) {
	    NEXT_INST_F(1, 1, 1);







	} else {

	    NEXT_INST_F(1, 0, 0);




	}












    }


	
    case INST_BREAK:








	Tcl_ResetResult(interp);



	result = TCL_BREAK;
	cleanup = 0;
	goto processExceptionReturn;


    case INST_CONTINUE:



	Tcl_ResetResult(interp);
	result = TCL_CONTINUE;



	cleanup = 0;



	goto processExceptionReturn;






    case INST_FOREACH_START4:
	opnd = TclGetUInt4AtPtr(pc+1);
	{
	    /*
	     * Initialize the temporary local var that holds the count
	     * of the number of iterations of the loop body to -1.
	     */

	    ForeachInfo *infoPtr = (ForeachInfo *)
	            codePtr->auxDataArrayPtr[opnd].clientData;
	    int iterTmpIndex = infoPtr->loopCtTemp;
	    Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
	    Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
	    Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;

	    if (oldValuePtr == NULL) {
		iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
		Tcl_IncrRefCount(iterVarPtr->value.objPtr);
	    } else {
		Tcl_SetLongObj(oldValuePtr, -1);
	    }
	    TclSetVarScalar(iterVarPtr);
	    TclClearVarUndefined(iterVarPtr);
	    TRACE(("%u => loop iter count temp %d\n", 
		   opnd, iterTmpIndex));
	}
	    
#ifndef TCL_COMPILE_DEBUG
	/* 
	 * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
	 * immediately after INST_FOREACH_START4 - let us just fall
	 * through instead of jumping back to the top.
	 */

	pc += 5;
#else
	NEXT_INST_F(5, 0, 0);
#endif	
    case INST_FOREACH_STEP4:
	opnd = TclGetUInt4AtPtr(pc+1);
	{
	    /*
	     * "Step" a foreach loop (i.e., begin its next iteration) by
	     * assigning the next value list element to each loop var.
	     */

	    ForeachInfo *infoPtr = (ForeachInfo *)
	            codePtr->auxDataArrayPtr[opnd].clientData;
	    ForeachVarList *varListPtr;
	    int numLists = infoPtr->numLists;
	    Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
	    Tcl_Obj *listPtr;
	    List *listRepPtr;
	    Var *iterVarPtr, *listVarPtr;
	    int iterNum, listTmpIndex, listLen, numVars;
	    int varIndex, valIndex, continueLoop, j;

	    /*
	     * Increment the temp holding the loop iteration number.
	     */

	    iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
	    valuePtr = iterVarPtr->value.objPtr;
	    iterNum = (valuePtr->internalRep.longValue + 1);
	    Tcl_SetLongObj(valuePtr, iterNum);
		
	    /*
	     * Check whether all value lists are exhausted and we should
	     * stop the loop.
	     */

	    continueLoop = 0;
	    listTmpIndex = infoPtr->firstValueTemp;
	    for (i = 0;  i < numLists;  i++) {
		varListPtr = infoPtr->varLists[i];
		numVars = varListPtr->numVars;
		    
		listVarPtr = &(compiledLocals[listTmpIndex]);
		listPtr = listVarPtr->value.objPtr;
		result = Tcl_ListObjLength(interp, listPtr, &listLen);
		if (result != TCL_OK) {
		    TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
		            opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));

		    goto checkForCatch;
		}
		if (listLen > (iterNum * numVars)) {
		    continueLoop = 1;
		}
		listTmpIndex++;
	    }

	    /*
	     * If some var in some var list still has a remaining list
	     * element iterate one more time. Assign to var the next
	     * element from its value list. We already checked above
	     * that each list temp holds a valid list object.
	     */
		
	    if (continueLoop) {
		listTmpIndex = infoPtr->firstValueTemp;
		for (i = 0;  i < numLists;  i++) {
		    varListPtr = infoPtr->varLists[i];
		    numVars = varListPtr->numVars;

		    listVarPtr = &(compiledLocals[listTmpIndex]);
		    listPtr = listVarPtr->value.objPtr;
		    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
		    listLen = listRepPtr->elemCount;
			
		    valIndex = (iterNum * numVars);
		    for (j = 0;  j < numVars;  j++) {
			int setEmptyStr = 0;
			if (valIndex >= listLen) {
			    setEmptyStr = 1;
			    TclNewObj(valuePtr);
			} else {
			    valuePtr = listRepPtr->elements[valIndex];
			}
			    
			varIndex = varListPtr->varIndexes[j];
			varPtr = &(varFramePtr->compiledLocals[varIndex]);
			part1 = varPtr->name;
			while (TclIsVarLink(varPtr)) {
			    varPtr = varPtr->value.linkPtr;
			}
			if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
			        && (varPtr->tracePtr == NULL)
			        && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
			    value2Ptr = varPtr->value.objPtr;
			    if (valuePtr != value2Ptr) {
				if (value2Ptr != NULL) {
				    TclDecrRefCount(value2Ptr);
				} else {
				    TclSetVarScalar(varPtr);
				    TclClearVarUndefined(varPtr);
				}
				varPtr->value.objPtr = valuePtr;
				Tcl_IncrRefCount(valuePtr);
			    }
			} else {
			    DECACHE_STACK_INFO();
			    value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, 
						     NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			    CACHE_STACK_INFO();
			    if (value2Ptr == NULL) {
				TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
						opnd, varIndex),
					       Tcl_GetObjResult(interp));
				if (setEmptyStr) {
				    TclDecrRefCount(valuePtr);
				}
				result = TCL_ERROR;
				goto checkForCatch;
			    }
			}
			valIndex++;
		    }
		    listTmpIndex++;
		}
	    }
	    TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, 
	            iterNum, (continueLoop? "continue" : "exit")));

	    /* 


	     * Run-time peep-hole optimisation: the compiler ALWAYS follows
	     * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
	     * instruction and jump direct from here.
	     */

	    pc += 5;
	    if (*pc == INST_JUMP_FALSE1) {
		NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);


	    } else {
		NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
	    }

	}

    case INST_BEGIN_CATCH4:
	/*
	 * Record start of the catch command with exception range index
	 * equal to the operand. Push the current stack depth onto the
	 * special catch stack.
	 */
	catchStackPtr[++catchTop] = stackTop;
	TRACE(("%u => catchTop=%d, stackTop=%d\n",
	       TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
	NEXT_INST_F(5, 0, 0);

    case INST_END_CATCH:
	catchTop--;
	result = TCL_OK;
	TRACE(("=> catchTop=%d\n", catchTop));
	NEXT_INST_F(1, 0, 0);
	    
    case INST_PUSH_RESULT:
	objResultPtr = Tcl_GetObjResult(interp);
	TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
	NEXT_INST_F(1, 0, 1);

    case INST_PUSH_RETURN_CODE:
	objResultPtr = Tcl_NewLongObj(result);
	TRACE(("=> %u\n", result));
	NEXT_INST_F(1, 0, 1);

    default:
	panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
    } /* end of switch on opCode */

    /*
     * Division by zero in an expression. Control only reaches this
     * point by "goto divideByZero".
     */
	
 divideByZero:
    Tcl_ResetResult(interp);
    Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
    Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
            (char *) NULL);
    result = TCL_ERROR;
    goto checkForCatch;
	
    /*
     * An external evaluation (INST_INVOKE or INST_EVAL) returned 
     * something different from TCL_OK, or else INST_BREAK or 
     * INST_CONTINUE were called.
     */

 processExceptionReturn:

#if TCL_COMPILE_DEBUG    
    switch (*pc) {
        case INST_INVOKE_STK1:
        case INST_INVOKE_STK4:
	    TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
	    break;
        case INST_EVAL_STK:
	    /*
	     * Note that the object at stacktop has to be used
	     * before doing the cleanup.
	     */

	    TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
	    break;
        default:
	    TRACE(("=> "));


    }		    

#endif	   
    if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
	rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
	if (rangePtr == NULL) {


	    TRACE_APPEND(("no encl. loop or catch, returning %s\n",
	            StringForResultCode(result)));


	    goto abnormalReturn;
	} 
	if (rangePtr->type == CATCH_EXCEPTION_RANGE) {



	    TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
	    goto processCatch;




	}

	while (cleanup--) {
	    valuePtr = POP_OBJECT();
	    TclDecrRefCount(valuePtr);
	}
	if (result == TCL_BREAK) {
	    result = TCL_OK;
	    pc = (codePtr->codeStart + rangePtr->breakOffset);
	    TRACE_APPEND(("%s, range at %d, new pc %d\n",
		   StringForResultCode(result),
		   rangePtr->codeOffset, rangePtr->breakOffset));
	    NEXT_INST_F(0, 0, 0);
	} else {
	    if (rangePtr->continueOffset == -1) {
		TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
		        StringForResultCode(result)));
		goto checkForCatch;
	    } 
	    result = TCL_OK;
	    pc = (codePtr->codeStart + rangePtr->continueOffset);
	    TRACE_APPEND(("%s, range at %d, new pc %d\n",
		   StringForResultCode(result),
		   rangePtr->codeOffset, rangePtr->continueOffset));
	    NEXT_INST_F(0, 0, 0);
	}
#if TCL_COMPILE_DEBUG    
    } else if (traceInstructions) {
	if ((result != TCL_ERROR) && (result != TCL_RETURN))  {
	    objPtr = Tcl_GetObjResult(interp);
	    TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", 
		    result, O2S(objPtr)));
	} else {
	    objPtr = Tcl_GetObjResult(interp);
	    TRACE_APPEND(("%s, result= \"%s\"\n", 
	            StringForResultCode(result), O2S(objPtr)));
	}
#endif
    }
	    	
    /*
     * Execution has generated an "exception" such as TCL_ERROR. If the
     * exception is an error, record information about what was being
     * executed when the error occurred. Find the closest enclosing
     * catch range, if any. If no enclosing catch range is found, stop
     * execution and return the "exception" code.
     */
	
 checkForCatch:
    if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
	bytes = GetSrcInfoForPc(pc, codePtr, &length);
	if (bytes != NULL) {
	    Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
	    iPtr->flags |= ERR_ALREADY_LOGGED;
	}
    }
    if (catchTop == -1) {
#ifdef TCL_COMPILE_DEBUG
	if (traceInstructions) {
	    fprintf(stdout, "   ... no enclosing catch, returning %s\n",
	            StringForResultCode(result));
	}
#endif
	goto abnormalReturn;
    }
    rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
    if (rangePtr == NULL) {
	/*
	 * This is only possible when compiling a [catch] that sends its
	 * script to INST_EVAL. Cannot correct the compiler without 
	 * breakingcompat with previous .tbc compiled scripts.
	 */
#ifdef TCL_COMPILE_DEBUG
	if (traceInstructions) {
	    fprintf(stdout, "   ... no enclosing catch, returning %s\n",
	            StringForResultCode(result));
	}
#endif
	goto abnormalReturn;
    }

    /*
     * A catch exception range (rangePtr) was found to handle an
     * "exception". It was found either by checkForCatch just above or
     * by an instruction during break, continue, or error processing.
     * Jump to its catchOffset after unwinding the operand stack to
     * the depth it had when starting to execute the range's catch
     * command.
     */

 processCatch:
    while (stackTop > catchStackPtr[catchTop]) {
	valuePtr = POP_OBJECT();
	TclDecrRefCount(valuePtr);
    }
#ifdef TCL_COMPILE_DEBUG
    if (traceInstructions) {
	fprintf(stdout, "  ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
	        rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
	        (unsigned int)(rangePtr->catchOffset));
    }
#endif	
    pc = (codePtr->codeStart + rangePtr->catchOffset);
    NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */

    /* 
     * end of infinite loop dispatching on instructions.
     */

    /*
     * Abnormal return code. Restore the stack to state it had when starting
     * to execute the ByteCode. Panic if the stack is below the initial level.
     */

 abnormalReturn:
    while (stackTop > initStackTop) {
	valuePtr = POP_OBJECT();
	TclDecrRefCount(valuePtr);
    }
    if (stackTop < initStackTop) {
	fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
	        (unsigned int)(pc - codePtr->codeStart),
		(unsigned int) stackTop,
		(unsigned int) initStackTop);
	panic("TclExecuteByteCode execution failure: end stack top < start stack top");
    }
	
    /*
     * Free the catch stack array if malloc'ed storage was used.
4572
4573
4574
4575
4576
4577
4578
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
    Tcl_ResetResult(interp);
    if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"can't use empty string as operand of \"",
		operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
    } else {
	char *msg = "non-numeric string";
	char *s;
	int length;


	s = Tcl_GetStringFromObj(opndPtr, &length);






































	if (TclLooksLikeInt(s, length)) {

























	    /*
	     * If something that looks like an integer appears here, then 
	     * it *must* be a bad octal or too large to represent [Bug  542588].

	     */

	    if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
		msg = "invalid octal number";
	    } else {
		msg = "integer value too large to represent";
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
		    "integer value too large to represent", (char *) NULL);
	    }
	} else {
	    /*
	     * See if the operand can be interpreted as a double in order to
	     * improve the error message.
	     */

	    double d;

	    if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
		msg = "floating-point value";
	    }
	}

	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
		msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
		"\"", (char *) NULL);
    }
}

/*







|

>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
|
>


|








|
|








>







4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
    Tcl_ResetResult(interp);
    if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"can't use empty string as operand of \"",
		operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
    } else {
	char *msg = "non-numeric string";
	char *s, *p;
	int length;
	int looksLikeInt = 0;

	s = Tcl_GetStringFromObj(opndPtr, &length);
	p = s;
	/*
	 * strtod() isn't at all consistent about detecting Inf and
	 * NaN between platforms.
	 */
	if (length == 3) {
	    if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
		    (s[2]=='n' || s[2]=='N')) {
		msg = "non-numeric floating-point value";
		goto makeErrorMessage;
	    }
	    if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
		    (s[2]=='f' || s[2]=='F')) {
		msg = "infinite floating-point value";
		goto makeErrorMessage;
	    }
	}

	/*
	 * We cannot use TclLooksLikeInt here because it passes strings
	 * like "10;" [Bug 587140]. We'll accept as "looking like ints"
	 * for the present purposes any string that looks formally like
	 * a (decimal|octal|hex) integer.
	 */

	while (length && isspace(UCHAR(*p))) {
	    length--;
	    p++;
	}
	if (length && ((*p == '+') || (*p == '-'))) {
	    length--;
	    p++;
	}
	if (length) {
	    if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
		p += 2;
		length -= 2;
		looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
		if (looksLikeInt) {
		    length--;
		    p++;
		    while (length && isxdigit(UCHAR(*p))) {
			length--;
			p++;
		    }
		}
	    } else {
		looksLikeInt = (length && isdigit(UCHAR(*p)));
		if (looksLikeInt) {
		    length--;
		    p++;
		    while (length && isdigit(UCHAR(*p))) {
			length--;
			p++;
		    }
		}
	    }
	    while (length && isspace(UCHAR(*p))) {
		length--;
		p++;
	    }
	    looksLikeInt = !length;
	}
	if (looksLikeInt) {
	    /*
	     * If something that looks like an integer could not be
	     * converted, then it *must* be a bad octal or too large
	     * to represent [Bug 542588].
	     */

	    if (TclCheckBadOctal(NULL, s)) {
		msg = "invalid octal number";
	    } else {
		msg = "integer value too large to represent";
		Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
		    "integer value too large to represent", (char *) NULL);
	    }
	} else {
	    /*
	     * See if the operand can be interpreted as a double in
	     * order to improve the error message.
	     */

	    double d;

	    if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
		msg = "floating-point value";
	    }
	}
      makeErrorMessage:
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
		msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
		"\"", (char *) NULL);
    }
}

/*
4771
4772
4773
4774
4775
4776
4777
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
    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 i, level;

    if (numRanges == 0) {
	return NULL;
    }
    rangeArrayPtr = codePtr->exceptArrayPtr;







    for (level = codePtr->maxExceptDepth;  level >= 0;  level--) {
	for (i = 0;  i < numRanges;  i++) {
	    rangePtr = &(rangeArrayPtr[i]);
	    if (rangePtr->nestingLevel == level) {
		int start = rangePtr->codeOffset;
		int end   = (start + rangePtr->numCodeBytes);
		if ((start <= pcOffset) && (pcOffset < end)) {

		    if ((!catchOnly)
			    || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
			return rangePtr;
		    }
		}
	    }
	}
    }
    return NULL;
}

/*







|




|
>
>
>
>
>
>

|
<
|
|
|
<
|
>
|
|
|
<
<







4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668

4669
4670
4671

4672
4673
4674
4675
4676


4677
4678
4679
4680
4681
4682
4683
    ByteCode* codePtr;		/* Points to the ByteCode in which to search
				 * for the enclosing ExceptionRange. */
{
    ExceptionRange *rangeArrayPtr;
    int numRanges = codePtr->numExceptRanges;
    register ExceptionRange *rangePtr;
    int pcOffset = (pc - codePtr->codeStart);
    register int start;

    if (numRanges == 0) {
	return NULL;
    }

    /* 
     * This exploits peculiarities of our compiler: nested ranges
     * are always *after* their containing ranges, so that by scanning
     * backwards we are sure that the first matching range is indeed
     * the deepest.
     */

    rangeArrayPtr = codePtr->exceptArrayPtr;

    rangePtr = rangeArrayPtr + numRanges;
    while (--rangePtr >= rangeArrayPtr) {
	start = rangePtr->codeOffset;

	if ((start <= pcOffset) &&
	        (pcOffset < (start + rangePtr->numCodeBytes))) {
	    if ((!catchOnly)
		    || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
		return rangePtr;


	    }
	}
    }
    return NULL;
}

/*
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
static char *
GetOpcodeName(pc)
    unsigned char *pc;		/* Points to the instruction whose name
				 * should be returned. */
{
    unsigned char opCode = *pc;
    
    return instructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * VerifyExprObjType --







|







4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
static char *
GetOpcodeName(pc)
    unsigned char *pc;		/* Points to the instruction whose name
				 * should be returned. */
{
    unsigned char opCode = *pc;
    
    return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * VerifyExprObjType --
5711
5712
5713
5714
5715
5716
5717
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
	    if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = i;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_LongAsWide(i);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		args[k].type = TCL_INT;
		args[k].intValue = i;
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    Tcl_WideInt w = valuePtr->internalRep.wideValue;
	    if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].wideValue = (Tcl_WideInt) Tcl_WideAsDouble(w);
	    } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].wideValue = Tcl_WideAsLong(w);
	    } else {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = w;
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	} else {
	    d = valuePtr->internalRep.doubleValue;
	    if (mathFuncPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].intValue = (long) d;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_DoubleAsWide(d);
#endif /* TCL_WIDE_INT_IS_LONG */
	    } else {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = d;
	    }
	}
    }








|

















|









|







5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
	    if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = i;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_LongAsWide(i);
#endif /* !TCL_WIDE_INT_IS_LONG */
	    } else {
		args[k].type = TCL_INT;
		args[k].intValue = i;
	    }
#ifndef TCL_WIDE_INT_IS_LONG
	} else if (valuePtr->typePtr == &tclWideIntType) {
	    Tcl_WideInt w = valuePtr->internalRep.wideValue;
	    if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
		args[k].type = TCL_DOUBLE;
		args[k].wideValue = (Tcl_WideInt) Tcl_WideAsDouble(w);
	    } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].wideValue = Tcl_WideAsLong(w);
	    } else {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = w;
	    }
#endif /* !TCL_WIDE_INT_IS_LONG */
	} else {
	    d = valuePtr->internalRep.doubleValue;
	    if (mathFuncPtr->argTypes[k] == TCL_INT) {
		args[k].type = TCL_INT;
		args[k].intValue = (long) d;
#ifndef TCL_WIDE_INT_IS_LONG
	    } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
		args[k].type = TCL_WIDE_INT;
		args[k].wideValue = Tcl_DoubleAsWide(d);
#endif /* !TCL_WIDE_INT_IS_LONG */
	    } else {
		args[k].type = TCL_DOUBLE;
		args[k].doubleValue = d;
	    }
	}
    }

5773
5774
5775
5776
5777
5778
5779




5780
5781
5782
5783
5784
5785
5786
    
    /*
     * Push the call's object result.
     */
    
    if (funcResult.type == TCL_INT) {
	PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));




    } else {
	d = funcResult.doubleValue;
	if (IS_NAN(d) || IS_INF(d)) {
	    TclExprFloatError(interp, d);
	    result = TCL_ERROR;
	    goto done;
	}







>
>
>
>







5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
    
    /*
     * Push the call's object result.
     */
    
    if (funcResult.type == TCL_INT) {
	PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
#ifndef TCL_WIDE_INT_IS_LONG
    } else if (funcResult.type == TCL_WIDE_INT) {
	PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
#endif /* !TCL_WIDE_INT_IS_LONG */
    } else {
	d = funcResult.doubleValue;
	if (IS_NAN(d) || IS_INF(d)) {
	    TclExprFloatError(interp, d);
	    result = TCL_ERROR;
	    goto done;
	}
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
     * 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",
		    instructionTable[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",
		    instructionTable[i].name);
        }
    }

#ifdef TCL_MEM_DEBUG
    fprintf(stdout, "\nHeap Statistics:\n");
    TclDumpMemoryInfo(stdout);
#endif







|








|
<







6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153

6154
6155
6156
6157
6158
6159
6160
     * Instruction counts.
     */

    fprintf(stdout, "\nInstruction counts:\n");
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
        if (statsPtr->instructionCount[i]) {
            fprintf(stdout, "%20s %8ld %6.1f%%\n",
		    tclInstructionTable[i].name,
		    statsPtr->instructionCount[i],
		    (statsPtr->instructionCount[i]*100.0) / numInstructions);
        }
    }

    fprintf(stdout, "\nInstructions NEVER executed:\n");
    for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
        if (statsPtr->instructionCount[i] == 0) {
            fprintf(stdout, "%20s\n", tclInstructionTable[i].name);

        }
    }

#ifdef TCL_MEM_DEBUG
    fprintf(stdout, "\nHeap Statistics:\n");
    TclDumpMemoryInfo(stdout);
#endif
Changes to generic/tclFCmd.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclFCmd.c
 *
 *      This file implements the generic portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclFCmd.c,v 1.13.8.2 2002/06/10 05:33:11 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Declarations for local procedures defined in this file:











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclFCmd.c
 *
 *      This file implements the generic portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclFCmd.c,v 1.13.8.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Declarations for local procedures defined in this file:
444
445
446
447
448
449
450


451
452
453
454
455
456
457
				 * rename them. */
    int force;			/* If non-zero, overwrite target file if it
				 * exists.  Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;


    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;







>
>







444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
				 * rename them. */
    int force;			/* If non-zero, overwrite target file if it
				 * exists.  Otherwise, error if target already
				 * exists. */
{
    int result;
    Tcl_Obj *errfile, *errorBuffer;
    /* If source is a link, then this is the real file/directory */
    Tcl_Obj *actualSource = NULL;
    Tcl_StatBuf sourceStatBuf, targetStatBuf;

    if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
	return TCL_ERROR;
544
545
546
547
548
549
550
551















































552
553
554
555
556
557
558
559
560
	/*
	 * The rename failed because the move was across file systems.
	 * Fall through to copy file and then remove original.  Note that
	 * the low-level Tcl_FSRenameFileProc in the filesystem is allowed 
	 * to implement cross-filesystem moves itself, if it desires.
	 */
    }
















































    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(source, 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.
		 */








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|







546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
	/*
	 * The rename failed because the move was across file systems.
	 * Fall through to copy file and then remove original.  Note that
	 * the low-level Tcl_FSRenameFileProc in the filesystem is allowed 
	 * to implement cross-filesystem moves itself, if it desires.
	 */
    }

    actualSource = source;
    Tcl_IncrRefCount(actualSource);
#if 0
#ifdef S_ISLNK
    /* 
     * To add a flag to make 'copy' copy links instead of files, we could
     * add a condition to ignore this 'if' here.
     */
    if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
	/* 
	 * We want to copy files not links.  Therefore we must follow the
	 * link.  There are two purposes to this 'stat' call here.  First
	 * we want to know if the linked-file/dir actually exists, and
	 * second, in the block of code which follows, some 20 lines
	 * down, we want to check if the thing is a file or directory.
	 */
	if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
	    /* Actual file doesn't exist */
	    Tcl_AppendResult(interp, 
		    "error copying \"", Tcl_GetString(source), 
		    "\": the target of this link doesn't exist",
		    (char *) NULL);
	    goto done;
	} else {
	    int counter = 0;
	    while (1) {
		Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
		if (path == NULL) {
		    break;
		}
		Tcl_DecrRefCount(actualSource);
		actualSource = path;
		counter++;
		/* Arbitrary limit of 20 links to follow */
		if (counter > 20) {
		    /* Too many links */
		    Tcl_SetErrno(EMLINK);
		    errfile = source;
		    goto done;
		}
	    }
	    /* Now 'actualSource' is the correct file */
	}
    }
#endif
#endif

    if (S_ISDIR(sourceStatBuf.st_mode)) {
	result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
	if (result != TCL_OK) {
	    if (errno == EXDEV) {
		/* 
		 * The copy failed because we're trying to do a
		 * cross-filesystem copy.  We do this through our Tcl
		 * library.
		 */
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(source, 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,







|







643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
		    errfile = source;
		} else if (Tcl_FSEqualPaths(errfile, target)) {
		    errfile = target;
		}
	    }
	}
    } else {
	result = Tcl_FSCopyFile(actualSource, target);
	if ((result != TCL_OK) && (errno == EXDEV)) {
	    result = TclCrossFilesystemCopy(interp, source, target);
	}
	if (result != TCL_OK) {
	    /* 
	     * We could examine 'errno' to double-check if the problem
	     * was with the target, but we checked the source above,
648
649
650
651
652
653
654



655
656
657
658
659
660
661
	}
	Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
		(char *) NULL);
    }
    if (errorBuffer != NULL) {
        Tcl_DecrRefCount(errorBuffer);
    }



    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * FileForceOption --







>
>
>







697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
	}
	Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
		(char *) NULL);
    }
    if (errorBuffer != NULL) {
        Tcl_DecrRefCount(errorBuffer);
    }
    if (actualSource != NULL) {
	Tcl_DecrRefCount(actualSource);
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * FileForceOption --
824
825
826
827
828
829
830

831
832
833
834
835











836
837
838
839
840
841
842
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
    	return TCL_ERROR;
    }
    
    objc -= 3;
    objv += 3;
    result = TCL_ERROR;

    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;
	if (objStrings == NULL) {











	    goto end;
	}
	/* We own the object now */
	Tcl_IncrRefCount(objStrings);
        /* Use objStrings as a list object */
	if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
	    goto end;







>





>
>
>
>
>
>
>
>
>
>
>







876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
    if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
    	return TCL_ERROR;
    }
    
    objc -= 3;
    objv += 3;
    result = TCL_ERROR;
    Tcl_SetErrno(0);
    attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
    if (attributeStrings == NULL) {
	int index;
	Tcl_Obj *objPtr;
	if (objStrings == NULL) {
	    if (Tcl_GetErrno() != 0) {
		/* 
		 * There was an error, probably that the filePtr is
		 * not accepted by any filesystem
		 */
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 
			"could not read \"", Tcl_GetString(filePtr), 
			"\": ", Tcl_PosixError(interp), 
			(char *) NULL);
		return TCL_ERROR;
	    }
	    goto end;
	}
	/* We own the object now */
	Tcl_IncrRefCount(objStrings);
        /* Use objStrings as a list object */
	if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
	    goto end;
Changes to generic/tclIO.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.c,v 1.38.2.2 2002/06/10 05:33:11 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclIO.h"
#include <assert.h>













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclIO.c --
 *
 *	This file provides the generic portions (those that are the same on
 *	all platforms and for all channel types) of Tcl's IO facilities.
 *
 * Copyright (c) 1998-2000 Ajuba Solutions
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIO.c,v 1.38.2.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclIO.h"
#include <assert.h>

3051
3052
3053
3054
3055
3056
3057

3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077

3078

3079
3080
3081
3082
3083
3084
3085
    int srcLen;			/* Length of UTF-8 string in bytes. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
    char *dst, *stage;
    int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
    int stageLen, toWrite, stageRead, endEncoding, result;

    Tcl_Encoding encoding;
    char safe[BUFFER_PADDING];
    
    total = 0;
    sawLF = 0;
    savedLF = 0;
    saved = 0;
    encoding = statePtr->encoding;

    /*
     * Write the terminated escape sequence even if srcLen is 0.
     */

    endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);

    /*
     * Loop over all UTF-8 characters in src, storing them in staging buffer
     * with proper EOL translation.
     */


    while (srcLen + savedLF + endEncoding > 0) {

	stage = statePtr->outputStage;
	stageMax = statePtr->bufSize;
	stageLen = stageMax;

	toWrite = stageLen;
	if (toWrite > srcLen) {
	    toWrite = srcLen;







>




















>
|
>







3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
    int srcLen;			/* Length of UTF-8 string in bytes. */
{
    ChannelState *statePtr = chanPtr->state;	/* state info for channel */
    ChannelBuffer *bufPtr;
    char *dst, *stage;
    int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
    int stageLen, toWrite, stageRead, endEncoding, result;
    int consumedSomething;
    Tcl_Encoding encoding;
    char safe[BUFFER_PADDING];
    
    total = 0;
    sawLF = 0;
    savedLF = 0;
    saved = 0;
    encoding = statePtr->encoding;

    /*
     * Write the terminated escape sequence even if srcLen is 0.
     */

    endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);

    /*
     * Loop over all UTF-8 characters in src, storing them in staging buffer
     * with proper EOL translation.
     */

    consumedSomething = 1;
    while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
        consumedSomething = 0;
	stage = statePtr->outputStage;
	stageMax = statePtr->bufSize;
	stageLen = stageMax;

	toWrite = stageLen;
	if (toWrite > srcLen) {
	    toWrite = srcLen;
3195
3196
3197
3198
3199
3200
3201


3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212









3213
3214
3215
3216
3217
3218
3219
	    }

	    total += dstWrote;
	    stage += stageRead;
	    stageLen -= stageRead;
	    sawLF = 0;



	    /*
	     * If all translated characters are written to the buffer,
	     * endEncoding is set to 0 because the escape sequence may be
	     * output.
	     */

	    if ((stageLen + saved == 0) && (result == 0)) {
		endEncoding = 0;
	    }
	}
    }









    return total;
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateOutputEOL --







>
>











>
>
>
>
>
>
>
>
>







3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
	    }

	    total += dstWrote;
	    stage += stageRead;
	    stageLen -= stageRead;
	    sawLF = 0;

	    consumedSomething = 1;

	    /*
	     * If all translated characters are written to the buffer,
	     * endEncoding is set to 0 because the escape sequence may be
	     * output.
	     */

	    if ((stageLen + saved == 0) && (result == 0)) {
		endEncoding = 0;
	    }
	}
    }

    /* If nothing was written and it happened because there was no progress
     * in the UTF conversion, we throw an error.
     */

    if (!consumedSomething && (total == 0)) {
        Tcl_SetErrno (EINVAL);
        return -1;
    }
    return total;
}

/*
 *---------------------------------------------------------------------------
 *
 * TranslateOutputEOL --
Changes to generic/tclIOSock.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 
 * tclIOSock.c --
 *
 *	Common routines used by all socket based channel types.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOSock.c,v 1.5.18.1 2002/02/05 02:22:00 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 *---------------------------------------------------------------------------










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 
 * tclIOSock.c --
 *
 *	Common routines used by all socket based channel types.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOSock.c,v 1.5.18.2 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 *---------------------------------------------------------------------------
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104

int
TclSockMinimumBuffers(sock, size)
    int sock;			/* Socket file descriptor */
    int size;			/* Minimum buffer size */
{
    int current;
    /*
     * Should be socklen_t, but HP10.20 (g)cc chokes
     */
    size_t len;

    len = sizeof(int);
    getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
    if (current < size) {
	len = sizeof(int);
	setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
    }







<
<
<
|







87
88
89
90
91
92
93



94
95
96
97
98
99
100
101

int
TclSockMinimumBuffers(sock, size)
    int sock;			/* Socket file descriptor */
    int size;			/* Minimum buffer size */
{
    int current;



    socklen_t len;

    len = sizeof(int);
    getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&current, &len);
    if (current < size) {
	len = sizeof(int);
	setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
    }
Changes to generic/tclIOUtil.c.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27




28
29
30
31
32
33
34
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.22.2.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#ifdef MAC_TCL
#include "tclMacInt.h"
#endif





/*
 * Prototypes for procedures defined later in this file.
 */

static void		DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));







|







>
>
>
>







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.22.2.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#ifdef MAC_TCL
#include "tclMacInt.h"
#endif
#ifdef __WIN32__
/* for tclWinProcs->useWide */
#include "tclWinInt.h"
#endif

/*
 * Prototypes for procedures defined later in this file.
 */

static void		DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr));
310
311
312
313
314
315
316



317
318
319
320
321
322
323
    int fileRefCount;             /* How many Tcl_Obj's use this
                                   * filesystem. */
    struct FilesystemRecord *nextPtr;  
                                  /* The next filesystem registered
                                   * to Tcl, or NULL if no more. */
} FilesystemRecord;




/* 
 * Declare the native filesystem support.  These functions should
 * be considered private to Tcl, and should really not be called
 * directly by any code other than this file (i.e. neither by
 * Tcl's core nor by extensions).  Similarly, the old string-based
 * Tclp... native filesystem functions should not be called.
 * 







>
>
>







314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
    int fileRefCount;             /* How many Tcl_Obj's use this
                                   * filesystem. */
    struct FilesystemRecord *nextPtr;  
                                  /* The next filesystem registered
                                   * to Tcl, or NULL if no more. */
} FilesystemRecord;

static FilesystemRecord* GetFilesystemRecord 
	_ANSI_ARGS_((Tcl_Filesystem *fromFilesystem, int *epoch));

/* 
 * Declare the native filesystem support.  These functions should
 * be considered private to Tcl, and should really not be called
 * directly by any code other than this file (i.e. neither by
 * Tcl's core nor by extensions).  Similarly, the old string-based
 * Tclp... native filesystem functions should not be called.
 * 
361
362
363
364
365
366
367

368






369
370
371
372
373
374
375
376
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;	    
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;	    
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;	    
Tcl_FSUnloadFileProc TclpUnloadFile;	    
Tcl_FSLinkProc TclpObjLink; 
Tcl_FSListVolumesProc TclpObjListVolumes;	    


/* Define the native filesystem dispatch table */






static Tcl_Filesystem nativeFilesystem = {
    "native",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_1,
    &NativePathInFilesystem,
    &NativeDupInternalRep,
    &NativeFreeInternalRep,
    &TclpNativeToNormalized,







>
|
>
>
>
>
>
>
|







368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;	    
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;	    
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;	    
Tcl_FSUnloadFileProc TclpUnloadFile;	    
Tcl_FSLinkProc TclpObjLink; 
Tcl_FSListVolumesProc TclpObjListVolumes;	    

/* 
 * Define the native filesystem dispatch table.  If necessary, it
 * is ok to make this non-static, but it should only be accessed
 * by the functions actually listed within it (or perhaps other
 * helper functions of them).  Anything which is not part of this
 * 'native filesystem implementation' should not be delving inside
 * here!
 */
static Tcl_Filesystem tclNativeFilesystem = {
    "native",
    sizeof(Tcl_Filesystem),
    TCL_FILESYSTEM_VERSION_1,
    &NativePathInFilesystem,
    &NativeDupInternalRep,
    &NativeFreeInternalRep,
    &TclpNativeToNormalized,
395
396
397
398
399
400
401
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
    &TclpObjCreateDirectory,
    &TclpObjRemoveDirectory, 
    &TclpObjDeleteFile,
    &TclpObjCopyFile,
    &TclpObjRenameFile,
    &TclpObjCopyDirectory, 
    &TclpObjLstat,
    &TclpLoadFile,
    &TclpObjGetCwd,
    &TclpObjChdir
};

/* 
 * Define the tail of the linked list.  Note that for unconventional
 * uses of Tcl without a native filesystem, we may in the future wish
 * to modify the current approach of hard-coding the native filesystem
 * in the lookup list 'filesystemList' below.
 * 
 * We initialize the record so that it thinks one file uses it.  This
 * means it will never be freed.
 */
static FilesystemRecord nativeFilesystemRecord = {
    NULL,
    &nativeFilesystem,
    1,
    NULL
};

/* 
 * The following few variables are protected by the 
 * filesystemMutex just below.
 */

/* 
 * This is incremented each time we modify the linked list of
 * filesystems.  Any time it changes, all cached filesystem
 * representations are suspect and must be freed.
 */
int theFilesystemEpoch = 0;


/* Stores the linked list of filesystems.*/

static FilesystemRecord *filesystemList = &nativeFilesystemRecord;

/* 
 * The number of loops which are currently iterating over the linked
 * list.  If this is greater than zero, we can't modify the list.
 */
int filesystemIteratorsInProgress = 0;


/* Someone wants to modify the list of filesystems if this is set. */

int filesystemWantToModify = 0;


Tcl_Condition filesystemOkToModify = NULL;


TCL_DECLARE_MUTEX(filesystemMutex)

/* 
 * struct FsPath --
 * 
 * Internal representation of a Tcl_Obj of "path" type.  This







|















|














|
>
>
|
>

>




|
>
>
|
>
|

>
|
>







409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
    &TclpObjCreateDirectory,
    &TclpObjRemoveDirectory, 
    &TclpObjDeleteFile,
    &TclpObjCopyFile,
    &TclpObjRenameFile,
    &TclpObjCopyDirectory, 
    &TclpObjLstat,
    &TclpDlopen,
    &TclpObjGetCwd,
    &TclpObjChdir
};

/* 
 * Define the tail of the linked list.  Note that for unconventional
 * uses of Tcl without a native filesystem, we may in the future wish
 * to modify the current approach of hard-coding the native filesystem
 * in the lookup list 'filesystemList' below.
 * 
 * We initialize the record so that it thinks one file uses it.  This
 * means it will never be freed.
 */
static FilesystemRecord nativeFilesystemRecord = {
    NULL,
    &tclNativeFilesystem,
    1,
    NULL
};

/* 
 * The following few variables are protected by the 
 * filesystemMutex just below.
 */

/* 
 * This is incremented each time we modify the linked list of
 * filesystems.  Any time it changes, all cached filesystem
 * representations are suspect and must be freed.
 */
static int theFilesystemEpoch = 0;

/*
 * Stores the linked list of filesystems.
 */
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;

/* 
 * The number of loops which are currently iterating over the linked
 * list.  If this is greater than zero, we can't modify the list.
 */
static int filesystemIteratorsInProgress = 0;

/*
 * Someone wants to modify the list of filesystems if this is set.
 */
static int filesystemWantToModify = 0;

#ifdef TCL_THREADS
static Tcl_Condition filesystemOkToModify = NULL;
#endif

TCL_DECLARE_MUTEX(filesystemMutex)

/* 
 * struct FsPath --
 * 
 * Internal representation of a Tcl_Obj of "path" type.  This
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
 * 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 {
    ClientData clientData;
    Tcl_FSUnloadFileProc *unloadProcPtr;	
    Tcl_Obj *divertedFile;
    Tcl_Filesystem *divertedFilesystem;
    ClientData divertedFileNativeRep;
} FsDivertLoad;

/* Now move on to the basic filesystem implementation */







|







526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
 * file from a file system by way of making a temporary copy of the
 * file on the native filesystem.  We need to store both the actual
 * unloadProc/clientData combination which was used, and the original
 * and modified filenames, so that we can correctly undo the entire
 * operation when we want to unload the code.
 */
typedef struct FsDivertLoad {
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unloadProcPtr;	
    Tcl_Obj *divertedFile;
    Tcl_Filesystem *divertedFilesystem;
    ClientData divertedFileNativeRep;
} FsDivertLoad;

/* Now move on to the basic filesystem implementation */
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
 *----------------------------------------------------------------------
 *
 * TclFinalizeFilesystem --
 *
 *	Clean up the filesystem.  After this, calls to all Tcl_FS...
 *	functions will fail.
 *	
 *	Note that, since 'TclFinalizedLoad' may unload extensions
 *	which implement other filesystems, and which may therefore
 *	contain a 'freeProc' for those filesystems, at this stage
 *	we _must_ have freed all objects of "path" type, or we may
 *	end up with segfaults if we try to free them later.
 *
 * Results:
 *	None.







|







581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
 *----------------------------------------------------------------------
 *
 * TclFinalizeFilesystem --
 *
 *	Clean up the filesystem.  After this, calls to all Tcl_FS...
 *	functions will fail.
 *	
 *	Note that, since 'TclFinalizeLoad' may unload extensions
 *	which implement other filesystems, and which may therefore
 *	contain a 'freeProc' for those filesystems, at this stage
 *	we _must_ have freed all objects of "path" type, or we may
 *	end up with segfaults if we try to free them later.
 *
 * Results:
 *	None.
1707
1708
1709
1710
1711
1712
1713





1714









1715














1716
1717
1718
1719
1720
1721
1722
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */
    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
	if (proc != NULL) {





	    return (*proc)(interp, pathPtr, modeString, permissions);









	}














    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *







>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */
    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
	if (proc != NULL) {
	    int mode, seekFlag;
	    mode = TclGetOpenMode(interp, modeString, &seekFlag);
	    if (mode == -1) {
	        return NULL;
	    }
	    retVal = (*proc)(interp, pathPtr, mode, permissions);
	    if (retVal != NULL) {
		if (seekFlag) {
		    if (Tcl_Seek(retVal, (Tcl_WideInt)0, 
				 SEEK_END) < (Tcl_WideInt)0) {
			if (interp != (Tcl_Interp *) NULL) {
			    Tcl_AppendResult(interp,
			      "could not seek to end of file while opening \"",
			      Tcl_GetString(pathPtr), "\": ", 
			      Tcl_PosixError(interp), (char *) NULL);
			}
			Tcl_Close(NULL, retVal);
			return NULL;
		    }
		}
	    }
	    return retVal;
	}
    }
    /* File doesn't belong to any filesystem that can open it */
    Tcl_SetErrno(ENOENT);
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open \"", 
			 Tcl_GetString(pathPtr), "\": ",
			 Tcl_PosixError(interp), (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
1782
1783
1784
1785
1786
1787
1788

1789
1790
1791
1792
1793
1794
1795
	    int len;
	    Tcl_GetStringFromObj(pathPtr,&len);
	    if (len != 0) {
		/* 
		 * We have no idea how to match files in a directory
		 * which belongs to no known filesystem
		 */

		return -1;
	    }
	}
	/* 
	 * We have an empty or NULL path.  This is defined to mean we
	 * must search for files within the current 'cwd'.  We
	 * therefore use that, but then since the proc we call will







>







1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
	    int len;
	    Tcl_GetStringFromObj(pathPtr,&len);
	    if (len != 0) {
		/* 
		 * We have no idea how to match files in a directory
		 * which belongs to no known filesystem
		 */
		Tcl_SetErrno(ENOENT);
		return -1;
	    }
	}
	/* 
	 * We have an empty or NULL path.  This is defined to mean we
	 * must search for files within the current 'cwd'.  We
	 * therefore use that, but then since the proc we call will
1881
1882
1883
1884
1885
1886
1887

1888
1889
1890
1891
1892
1893
1894
		}
		Tcl_DecrRefCount(tmpResultPtr);
	    }
	}
	Tcl_DecrRefCount(cwd);
	return ret;
    }

    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetCwd --







>







1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
		}
		Tcl_DecrRefCount(tmpResultPtr);
	    }
	}
	Tcl_DecrRefCount(cwd);
	return ret;
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetCwd --
2235
2236
2237
2238
2239
2240
2241

2242
2243
2244
2245
2246
2247
2248
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, objPtrRef);
	}
    }

    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsGet --







>







2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, objPtrRef);
	}
    }
    Tcl_SetErrno(ENOENT);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsGet --
2275
2276
2277
2278
2279
2280
2281

2282
2283
2284
2285
2286
2287
2288
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
	if (proc != NULL) {
	    return (*proc)(interp, index, pathPtr, objPtrRef);
	}
    }

    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsSet --







>







2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
	if (proc != NULL) {
	    return (*proc)(interp, index, pathPtr, objPtrRef);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSFileAttrsSet --
2310
2311
2312
2313
2314
2315
2316

2317
2318
2319
2320
2321
2322
2323
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
	if (proc != NULL) {
	    return (*proc)(interp, index, pathPtr, objPtr);
	}
    }

    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSChdir --







>







2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
	if (proc != NULL) {
	    return (*proc)(interp, index, pathPtr, objPtr);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSChdir --
2430
2431
2432
2433
2434
2435
2436
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
 *	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.  We remember which
 *	filesystem loaded the code, so that we can use that filesystem's
 *	unloadProc to unload the code when that occurs.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLoadFile(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. */
    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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
	if (proc != NULL) {
	    int retVal = (*proc)(interp, pathPtr, sym1, sym2,
			     proc1Ptr, proc2Ptr, clientDataPtr, 


			     unloadProcPtr);








	    return retVal;
	} else {
	    Tcl_Filesystem *copyFsPtr;
	    Tcl_Obj *copyToPtr;
	    
	    /* First check if it is readable -- and exists! */
	    if (Tcl_FSAccess(pathPtr, R_OK) != 0) {







|
<
|






|








|











|
|
>
>
|
>
>
>
>
>
>
>
>







2486
2487
2488
2489
2490
2491
2492
2493

2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
 *	paths are always used.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.  This may later be

 *	unloaded by passing the clientData to the unloadProc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, 
	       handlePtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code. */
    CONST char *sym1, *sym2;	/* Names of two procedures to look up in
				 * the file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
				/* Where to return the addresses corresponding
				 * to sym1 and sym2. */
    Tcl_LoadHandle *handlePtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
                                /* Filled with address of Tcl_FSUnloadFileProc
                                 * function which should be used for
                                 * this file. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
	if (proc != NULL) {
	    int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
	    if (retVal != TCL_OK) {
		return retVal;
	    }
	    if (*handlePtr == NULL) {
		return TCL_ERROR;
	    }
	    if (sym1 != NULL) {
	        *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
	    }
	    if (sym2 != NULL) {
	        *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
	    }
	    return retVal;
	} else {
	    Tcl_Filesystem *copyFsPtr;
	    Tcl_Obj *copyToPtr;
	    
	    /* First check if it is readable -- and exists! */
	    if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
2514
2515
2516
2517
2518
2519
2520
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
		 * 
		 * Tcl_Obj* perm = Tcl_NewStringObj("0777",-1);
		 * Tcl_IncrRefCount(perm);
		 * Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
		 * Tcl_DecrRefCount(perm);
		 * 
		 */
		ClientData newClientData = NULL;
		Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
		FsDivertLoad *tvdlPtr;
		int retVal;
		
		retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
					proc1Ptr, proc2Ptr, &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);
		    (*clientDataPtr) = NULL;
		    (*unloadProcPtr) = NULL;
		    return TCL_OK;
		}
		/* 
		 * When we unload this file, we need to divert the 
		 * unloading so we can unload and cleanup the 
		 * temporary file correctly.
		 */
		tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));

		/* 
		 * Remember three pieces of information.  This allows
		 * us to cleanup the diverted load completely, on
		 * platforms which allow proper unloading of code.
		 */
		tvdlPtr->clientData = newClientData;
		tvdlPtr->unloadProcPtr = newUnloadProcPtr;
		/* copyToPtr is already incremented for this reference */
		tvdlPtr->divertedFile = copyToPtr;
		/* 
		 * This is the filesystem we loaded it into.  It is
		 * almost certainly the nativeFilesystem, but we don't
		 * want to make that assumption.  Since we have a
		 * reference to 'copyToPtr', we already have a refCount
		 * on this filesystem, so we don't need to worry about it
		 * disappearing on us.
		 */
		tvdlPtr->divertedFilesystem = copyFsPtr;
		/* Get the native representation of the file path */
		tvdlPtr->divertedFileNativeRep = Tcl_FSGetInternalRep(copyToPtr,
								      copyFsPtr);
		copyToPtr = NULL;
		(*clientDataPtr) = (ClientData) tvdlPtr;
		(*unloadProcPtr) = &FSUnloadTempFile;
		
		return retVal;
	    } else {
		/* Cross-platform copy failed */
		Tcl_FSDeleteFile(copyToPtr);
		Tcl_DecrRefCount(copyToPtr);
		return TCL_ERROR;
	    }
	}
    }

    return -1;
}











































/*
 *---------------------------------------------------------------------------
 *
 * FSUnloadTempFile --
 *
 *	This function is called when we loaded a library of code via







|





|
>














|















|





|










|











>


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
		 * 
		 * Tcl_Obj* perm = Tcl_NewStringObj("0777",-1);
		 * Tcl_IncrRefCount(perm);
		 * Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
		 * Tcl_DecrRefCount(perm);
		 * 
		 */
		Tcl_LoadHandle newLoadHandle = NULL;
		Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
		FsDivertLoad *tvdlPtr;
		int retVal;
		
		retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
					proc1Ptr, proc2Ptr, 
					&newLoadHandle,
					&newUnloadProcPtr);
	        if (retVal != TCL_OK) {
		    /* The file didn't load successfully */
		    Tcl_FSDeleteFile(copyToPtr);
		    Tcl_DecrRefCount(copyToPtr);
		    return retVal;
		}
		/* 
		 * Try to delete the file immediately -- this is
		 * possible in some OSes, and avoids any worries
		 * about leaving the copy laying around on exit. 
		 */
		if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
		    Tcl_DecrRefCount(copyToPtr);
		    (*handlePtr) = NULL;
		    (*unloadProcPtr) = NULL;
		    return TCL_OK;
		}
		/* 
		 * When we unload this file, we need to divert the 
		 * unloading so we can unload and cleanup the 
		 * temporary file correctly.
		 */
		tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));

		/* 
		 * Remember three pieces of information.  This allows
		 * us to cleanup the diverted load completely, on
		 * platforms which allow proper unloading of code.
		 */
		tvdlPtr->loadHandle = newLoadHandle;
		tvdlPtr->unloadProcPtr = newUnloadProcPtr;
		/* copyToPtr is already incremented for this reference */
		tvdlPtr->divertedFile = copyToPtr;
		/* 
		 * This is the filesystem we loaded it into.  It is
		 * almost certainly the tclNativeFilesystem, but we don't
		 * want to make that assumption.  Since we have a
		 * reference to 'copyToPtr', we already have a refCount
		 * on this filesystem, so we don't need to worry about it
		 * disappearing on us.
		 */
		tvdlPtr->divertedFilesystem = copyFsPtr;
		/* Get the native representation of the file path */
		tvdlPtr->divertedFileNativeRep = Tcl_FSGetInternalRep(copyToPtr,
								      copyFsPtr);
		copyToPtr = NULL;
		(*handlePtr) = (Tcl_LoadHandle) tvdlPtr;
		(*unloadProcPtr) = &FSUnloadTempFile;
		
		return retVal;
	    } else {
		/* Cross-platform copy failed */
		Tcl_FSDeleteFile(copyToPtr);
		Tcl_DecrRefCount(copyToPtr);
		return TCL_ERROR;
	    }
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}
/* 
 * This function used to be in the platform specific directories, but it
 * has now been made to work cross-platform
 */
int
TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, 
	     clientDataPtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */
    CONST char *sym1, *sym2;	/* Names of two procedures to look up in
				 * the file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
				/* Where to return the addresses corresponding
				 * to sym1 and sym2. */
    ClientData *clientDataPtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    Tcl_LoadHandle handle = NULL;
    int res;
    
    res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
    
    if (res != TCL_OK) {
        return res;
    }

    if (handle == NULL) {
	return TCL_ERROR;
    }
    
    *clientDataPtr = (ClientData)handle;
    
    *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
    *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * FSUnloadTempFile --
 *
 *	This function is called when we loaded a library of code via
2603
2604
2605
2606
2607
2608
2609
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
 * Side effects:
 *	The effects of the 'unload' function called, and of course
 *	the temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */
static void 
FSUnloadTempFile(clientData)
    ClientData clientData;    /* ClientData returned by a previous call
			       * to Tcl_FSLoadFile().  The clientData is 
			       * a token that represents the loaded 
			       * file. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad*)clientData;
    /* 
     * 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->clientData);
    }
    
    /* Remove the temporary file we created. */
    if (Tcl_FSDeleteFile(tvdlPtr->divertedFile) != TCL_OK) {
	/* 
	 * The above may have failed because the filesystem, or something
	 * it depends upon (e.g. encodings) are being taken down because







|
|
|



|














|







2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
 * Side effects:
 *	The effects of the 'unload' function called, and of course
 *	the temporary file will be deleted.
 *
 *---------------------------------------------------------------------------
 */
static void 
FSUnloadTempFile(loadHandle)
    Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
			       * to Tcl_FSLoadFile().  The loadHandle is 
			       * a token that represents the loaded 
			       * file. */
{
    FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;
    /* 
     * This test should never trigger, since we give
     * the client data in the function above.
     */
    if (tvdlPtr == NULL) { return; }
    
    /* 
     * Call the real 'unloadfile' proc we actually used. It is very
     * important that we call this first, so that the shared library
     * is actually unloaded by the OS.  Otherwise, the following
     * 'delete' may well fail because the shared library is still in
     * use.
     */
    if (tvdlPtr->unloadProcPtr != NULL) {
	(*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
    }
    
    /* Remove the temporary file we created. */
    if (Tcl_FSDeleteFile(tvdlPtr->divertedFile) != TCL_OK) {
	/* 
	 * The above may have failed because the filesystem, or something
	 * it depends upon (e.g. encodings) are being taken down because
2679
2680
2681
2682
2683
2684
2685
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
 * 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
 *      was successful, or NULL if not.  In this case the result has no
 *      additional reference count, and need not be freed.





 *      
 *      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.
 *      
 *      Note: currently no Tcl filesystems support the 'link' action,
 *      so we actually always return an error for that call.
 *
 * Side effects:
 *	See readlink() documentation.

 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSLink(pathPtr, toPtr)
    Tcl_Obj *pathPtr;		/* Path of file to readlink or link */
    Tcl_Obj *toPtr;		/* NULL or path to be linked to */

{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLinkProc *proc = fsPtr->linkProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, toPtr);
	}
    }
    /*
     * 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;


#endif /* S_IFLNK */
    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *







|

|
>
>
>
>
>





<
<
<

|
>





|


>





|











>
>







2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807



2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
 * Results:
 *      If toPtr is NULL, then the result is a Tcl_Obj specifying the 
 *      contents of the symbolic link given by 'pathPtr', or NULL if
 *      the symbolic link could not be read.  The result is owned by
 *      the caller, which should call Tcl_DecrRefCount when the result
 *      is no longer needed.
 *      
 *      If toPtr is non-NULL, then the result is toPtr if the link action
 *      was successful, or NULL if not.  In this case the result has no
 *      additional reference count, and need not be freed.  The actual
 *      action to perform is given by the 'linkAction' flags, which is
 *      an or'd combination of:
 *      
 *        TCL_CREATE_SYMBOLIC_LINK
 *        TCL_CREATE_HARD_LINK
 *      
 *      Note that most filesystems will not support linking across
 *      to different filesystems, so this function will usually
 *      fail unless toPtr is in the same FS as pathPtr.
 *      



 * Side effects:
 *	See readlink() documentation.  A new filesystem link 
 *	object may appear
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;		/* Path of file to readlink or link */
    Tcl_Obj *toPtr;		/* NULL or path to be linked to */
    int linkAction;             /* Action to perform */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSLinkProc *proc = fsPtr->linkProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, toPtr, linkAction);
	}
    }
    /*
     * If S_IFLNK isn't defined it means that the machine doesn't
     * support symbolic links, so the file can't possibly be a
     * symbolic link.  Generate an EINVAL error, which is what
     * happens on machines that do support symbolic links when
     * you invoke readlink on a file that isn't a symbolic link.
     */
#ifndef S_IFLNK
    errno = EINVAL;
#else
    Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
    return NULL;
}

/*
 *---------------------------------------------------------------------------
 *
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
    
    /*
     * Perform platform specific splitting. 
     */

    if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) 
	== TCL_PATH_ABSOLUTE) {
	if (fsPtr == &nativeFilesystem) {
	    return TclpNativeSplitPath(pathPtr, lenPtr);
	}
    } else {
	return TclpNativeSplitPath(pathPtr, lenPtr);
    }

    /* We assume separators are single characters */







|







2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
    
    /*
     * Perform platform specific splitting. 
     */

    if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) 
	== TCL_PATH_ABSOLUTE) {
	if (fsPtr == &tclNativeFilesystem) {
	    return TclpNativeSplitPath(pathPtr, lenPtr);
	}
    } else {
	return TclpNativeSplitPath(pathPtr, lenPtr);
    }

    /* We assume separators are single characters */
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
	 * 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 == &nativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;
	    
	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);







|







3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
	 * A NULL value for fsPtr at this stage basically means
	 * we're trying to join a relative path onto something
	 * which is also relative (or empty).  There's nothing
	 * particularly wrong with that.
	 */
	if (*strElt == '\0') continue;
	
	if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
	    TclpNativeJoinPath(res, strElt);
	} else {
	    char separator = '/';
	    int needsSep = 0;
	    
	    if (fsPtr->filesystemSeparatorProc != NULL) {
		Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
	 * 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 != &nativeFilesystem) && (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







|







3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
	 * to skip the native filesystem --- since the tclFilename.c
	 * code has nice fast 'absolute path' checkers, we don't want
	 * to waste time repeating that effort here, and this 
	 * function is actually called quite often, so if we can
	 * save the overhead of the native filesystem returning us
	 * a list of volumes all the time, it is better.
	 */
	if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
	    int numVolumes;
	    Tcl_Obj *thisFsVolumes = (*proc)();
	    if (thisFsVolumes != NULL) {
		if (Tcl_ListObjLength(NULL, thisFsVolumes, 
				      &numVolumes) != TCL_OK) {
		    /* 
		     * This is VERY bad; the Tcl_FSListVolumesProc
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
    }
    FsReleaseIterator();
    
    if (type != TCL_PATH_ABSOLUTE) {
	type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, 
				     driveNameRef);
	if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
	    *filesystemPtrPtr = &nativeFilesystem;
	}
    }
    return type;
}

/*
 *---------------------------------------------------------------------------







|







3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
    }
    FsReleaseIterator();
    
    if (type != TCL_PATH_ABSOLUTE) {
	type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, 
				     driveNameRef);
	if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
	    *filesystemPtrPtr = &tclNativeFilesystem;
	}
    }
    return type;
}

/*
 *---------------------------------------------------------------------------
3385
3386
3387
3388
3389
3390
3391

3392
3393
3394
3395
3396
3397
3398
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr);
	}
    }

    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCreateDirectory --







>







3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCreateDirectory --
3416
3417
3418
3419
3420
3421
3422

3423
3424
3425
3426
3427
3428
3429
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr);
	}
    }

    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyDirectory --







>







3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSCopyDirectory --
3525
3526
3527
3528
3529
3530
3531

3532
3533
3534
3535
3536
3537
3538
		    }
		    Tcl_DecrRefCount(cwdPtr);
		}
	    }
	    return (*proc)(pathPtr, recursive, errorPtr);
	}
    }

    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSConvertToPathType --







>







3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
		    }
		    Tcl_DecrRefCount(cwdPtr);
		}
	    }
	    return (*proc)(pathPtr, recursive, errorPtr);
	}
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSConvertToPathType --
3720
3721
3722
3723
3724
3725
3726
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
    Tcl_Obj *transPtr;
    char *name;
    
    if (objPtr->typePtr == &tclFsPathType) {
	return TCL_OK;
    }
    
    /* Free old representation */
    if (objPtr->typePtr != NULL) {
	if (objPtr->bytes == NULL) {
	    if (objPtr->typePtr->updateStringProc == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "can't find object",
				     "string representation", (char *) NULL);
		}
	        return TCL_ERROR;
	    }
	    objPtr->typePtr->updateStringProc(objPtr);
	}
	if ((objPtr->typePtr->freeIntRepProc) != NULL) {
	    (*objPtr->typePtr->freeIntRepProc)(objPtr);
	}
    }

    /* 
     * 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.







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







3838
3839
3840
3841
3842
3843
3844


















3845
3846
3847
3848
3849
3850
3851
    Tcl_Obj *transPtr;
    char *name;
    
    if (objPtr->typePtr == &tclFsPathType) {
	return TCL_OK;
    }
    


















    /* 
     * First step is to translate the filename.  This is similar to
     * Tcl_TranslateFilename, but shouldn't convert everything to
     * windows backslashes on that platform.  The current
     * implementation of this piece is a slightly optimised version
     * of the various Tilde/Split/Join stuff to avoid multiple
     * split/join operations.
3858
3859
3860
3861
3862
3863
3864






3865
3866
3867
3868
3869
3870
3871
    Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
    fsPathPtr->normPathPtr = NULL;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = theFilesystemEpoch;







    objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
    objPtr->typePtr = &tclFsPathType;

    return TCL_OK;
}

/*







>
>
>
>
>
>







3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
    Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
    fsPathPtr->normPathPtr = NULL;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = NULL;
    fsPathPtr->fsRecPtr = NULL;
    fsPathPtr->filesystemEpoch = theFilesystemEpoch;

    /*
     * Free old representation before installing our new one.
     */
    if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
	(objPtr->typePtr->freeIntRepProc)(objPtr);
    }
    objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
    objPtr->typePtr = &tclFsPathType;

    return TCL_OK;
}

/*
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903

3904

3905

3906

3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
 *	New memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
    Tcl_Obj* fromFilesystem;
    ClientData clientData;
{
    Tcl_Obj *objPtr;
    FsPath *fsPathPtr, *fsFromPtr;

    Tcl_FSInternalToNormalizedProc *proc;

    

    if (Tcl_FSConvertToPathType(NULL, fromFilesystem) != TCL_OK) {

        return NULL;
    }
    
    fsFromPtr = (FsPath*) fromFilesystem->internalRep.otherValuePtr;

    proc = fsFromPtr->fsRecPtr->fsPtr->internalToNormalizedProc;

    if (proc == NULL) {
        return NULL;
    }
    
    objPtr = (*proc)(clientData);
    if (objPtr == NULL) {







|



|
>

>

>
|
>
|


<
<
|







3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019


4020
4021
4022
4023
4024
4025
4026
4027
 *	New memory may be allocated.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
    Tcl_Filesystem* fromFilesystem;
    ClientData clientData;
{
    Tcl_Obj *objPtr;
    FsPath *fsPathPtr;
    FilesystemRecord *fsFromPtr;
    Tcl_FSInternalToNormalizedProc *proc;
    int epoch;
    
    fsFromPtr = GetFilesystemRecord(fromFilesystem, &epoch);

    if (fsFromPtr == NULL) {
	return NULL;
    }
    


    proc = fsFromPtr->fsPtr->internalToNormalizedProc;

    if (proc == NULL) {
        return NULL;
    }
    
    objPtr = (*proc)(clientData);
    if (objPtr == NULL) {
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
    
    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
    fsPathPtr->translatedPathPtr = NULL;
    /* Circular reference, by design */
    fsPathPtr->normPathPtr = objPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = clientData;
    fsPathPtr->fsRecPtr = fsFromPtr->fsRecPtr;
    /* We must increase the refCount for this filesystem. */
    fsPathPtr->fsRecPtr->fileRefCount++;
    fsPathPtr->filesystemEpoch = fsFromPtr->filesystemEpoch;

    objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
    objPtr->typePtr = &tclFsPathType;
    return objPtr;
}

static void







|


|







4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
    
    fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
    fsPathPtr->translatedPathPtr = NULL;
    /* Circular reference, by design */
    fsPathPtr->normPathPtr = objPtr;
    fsPathPtr->cwdPtr = NULL;
    fsPathPtr->nativePathPtr = clientData;
    fsPathPtr->fsRecPtr = fsFromPtr;
    /* We must increase the refCount for this filesystem. */
    fsPathPtr->fsRecPtr->fileRefCount++;
    fsPathPtr->filesystemEpoch = epoch;

    objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
    objPtr->typePtr = &tclFsPathType;
    return objPtr;
}

static void
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
 *
 * Side effects:
 *	See Tcl_FSGetInternalRep.
 *
 *---------------------------------------------------------------------------
 */

CONST char* 
Tcl_FSGetNativePath(pathObjPtr)
    Tcl_Obj* pathObjPtr;
{
    return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &nativeFilesystem);
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeCreateNativeRep --
 *







|

|

|







4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
 *
 * Side effects:
 *	See Tcl_FSGetInternalRep.
 *
 *---------------------------------------------------------------------------
 */

CONST char *
Tcl_FSGetNativePath(pathObjPtr)
    Tcl_Obj *pathObjPtr;
{
    return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
}

/*
 *---------------------------------------------------------------------------
 *
 * NativeCreateNativeRep --
 *
4377
4378
4379
4380
4381
4382
4383





4384
4385
4386

4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398

    /* Make sure the normalized path is set */
    normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);

    str = Tcl_GetStringFromObj(normPtr,&len);
#ifdef __WIN32__
    Tcl_WinUtfToTChar(str, len, &ds);





    nativePathPtr = ckalloc((unsigned)(2+Tcl_DStringLength(&ds)));
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), 
	   (size_t) (2+Tcl_DStringLength(&ds)));

#else
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    nativePathPtr = ckalloc((unsigned)(1+Tcl_DStringLength(&ds)));
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), 
	  (size_t) (1+Tcl_DStringLength(&ds)));
#endif
	  
    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*







>
>
>
>
>
|
|
|
>


|

|







4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512

    /* Make sure the normalized path is set */
    normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);

    str = Tcl_GetStringFromObj(normPtr,&len);
#ifdef __WIN32__
    Tcl_WinUtfToTChar(str, len, &ds);
    if (tclWinProcs->useWide) {
	nativePathPtr = ckalloc((unsigned)(sizeof(WCHAR)+Tcl_DStringLength(&ds)));
	memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), 
	       (size_t) (sizeof(WCHAR)+Tcl_DStringLength(&ds)));
    } else {
	nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds)));
	memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), 
	       (size_t) (sizeof(char)+Tcl_DStringLength(&ds)));
    }
#else
    Tcl_UtfToExternalDString(NULL, str, len, &ds);
    nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds)));
    memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), 
	  (size_t) (sizeof(char)+Tcl_DStringLength(&ds)));
#endif
	  
    Tcl_DStringFree(&ds);
    return (ClientData)nativePathPtr;
}

/*
4413
4414
4415
4416
4417
4418
4419


4420
4421
4422
4423
4424
4425





















4426
4427
4428
4429
4430
4431
4432
4433
 */
Tcl_Obj* 
TclpNativeToNormalized(clientData)
    ClientData clientData;
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;


    
#ifdef __WIN32__
    Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
    Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif





















    objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
    Tcl_DStringFree(&ds);
    
    return objPtr;
}


/*







>
>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|







4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
 */
Tcl_Obj* 
TclpNativeToNormalized(clientData)
    ClientData clientData;
{
    Tcl_DString ds;
    Tcl_Obj *objPtr;
    CONST char *copy;
    int len;
    
#ifdef __WIN32__
    Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
    Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif
    
    copy = Tcl_DStringValue(&ds);
    len = Tcl_DStringLength(&ds);

#ifdef __WIN32__
    /* 
     * Certain native path representations on Windows have this special
     * prefix to indicate that they are to be treated specially.  For
     * example extremely long paths, or symlinks 
     */
    if (*copy == '\\') {
        if (0 == strncmp(copy,"\\??\\",4)) {
	    copy += 4;
	    len -= 4;
	} else if (0 == strncmp(copy,"\\\\?\\",4)) {
	    copy += 4;
	    len -= 4;
	}
    }
#endif

    objPtr = Tcl_NewStringObj(copy,len);
    Tcl_DStringFree(&ds);
    
    return objPtr;
}


/*
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458






4459

4460
4461
4462
4463
4464



4465




4466
4467
4468
4469
4470
4471
4472
 *
 *---------------------------------------------------------------------------
 */
static ClientData 
NativeDupInternalRep(clientData)
    ClientData clientData;
{
#ifdef __WIN32__
    /* Copying internal representations is complicated with multi-byte TChars */
    return NULL;
#else
    if (clientData == NULL) {
        return NULL;






    } else {

	char *native = (char*)clientData;
	char *copy = ckalloc((unsigned)(1+strlen(native)));
	strcpy(copy,native);
	return (ClientData)copy;
    }



#endif




}

/*
 *---------------------------------------------------------------------------
 *
 * NativePathInFilesystem --
 *







|
|
|
<

|
>
>
>
>
>
>

>
|
<
<
<

>
>
>

>
>
>
>







4583
4584
4585
4586
4587
4588
4589
4590
4591
4592

4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603



4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
 *
 *---------------------------------------------------------------------------
 */
static ClientData 
NativeDupInternalRep(clientData)
    ClientData clientData;
{
    ClientData copy;
    size_t len;


    if (clientData == NULL) {
	return NULL;
    }

#ifdef __WIN32__
    if (tclWinProcs->useWide) {
	/* unicode representation when running on NT/2K/XP */
	len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
    } else {
	/* ansi representation when running on 95/98/ME */
	len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));



    }
#else
    /* ansi representation when running on Unix/MacOS */
    len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
#endif
    
    copy = (ClientData) ckalloc(len);
    memcpy((VOID*)copy, (VOID*)clientData, len);
    return copy;
}

/*
 *---------------------------------------------------------------------------
 *
 * NativePathInFilesystem --
 *
4662
4663
4664
4665
4666
4667
4668
4669





4670
4671
4672
4673
4674







4675
4676
4677
4678
4679
4680
4681
Tcl_FSGetFileSystemForPath(pathObjPtr)
    Tcl_Obj* pathObjPtr;
{
    FilesystemRecord *fsRecPtr;
    Tcl_Filesystem* retVal = NULL;
    FsPath* srcFsPathPtr;
    
    /* Make sure pathObjPtr is of our type */






    if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
	return NULL;
    }
    







    if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
	return NULL;
    }
    
    /* 
     * Get a lock on theFilesystemEpoch and the filesystemList
     * 







|
>
>
>
>
>
|
|
|


>
>
>
>
>
>
>







4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
Tcl_FSGetFileSystemForPath(pathObjPtr)
    Tcl_Obj* pathObjPtr;
{
    FilesystemRecord *fsRecPtr;
    Tcl_Filesystem* retVal = NULL;
    FsPath* srcFsPathPtr;
    
    /* 
     * If the object has a refCount of zero, we reject it.  This
     * is to avoid possible segfaults or nondeterministic memory
     * leaks (i.e. the user doesn't know if they should decrement
     * the ref count on return or not).
     */
    
    if (pathObjPtr->refCount == 0) {
        return NULL;
    }
    
    /* 
     * This will ensure the pathObjPtr can be converted into a 
     * "path" type, and that we are able to generate a complete
     * normalized path which is used to determine the filesystem
     * match.
     */

    if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
	return NULL;
    }
    
    /* 
     * Get a lock on theFilesystemEpoch and the filesystemList
     * 
4739
4740
4741
4742
4743
4744
4745


















4746
4747
4748
4749
4750
4751
4752
	fsRecPtr = fsRecPtr->nextPtr;
    }

  done:
    FsReleaseIterator();
    return retVal;
}



















/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSEqualPaths --
 *
 *      This function tests whether the two paths given are equal path







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
	fsRecPtr = fsRecPtr->nextPtr;
    }

  done:
    FsReleaseIterator();
    return retVal;
}

/* Simple helper function */
static FilesystemRecord* 
GetFilesystemRecord(fromFilesystem, epoch)
    Tcl_Filesystem *fromFilesystem;
    int *epoch;
{
    FilesystemRecord *fsRecPtr = FsGetIterator();
    while (fsRecPtr != NULL) {
	if (fsRecPtr->fsPtr == fromFilesystem) {
	    *epoch = theFilesystemEpoch;
	    break;
	}
	fsRecPtr = fsRecPtr->nextPtr;
    }
    FsReleaseIterator();
    return fsRecPtr;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSEqualPaths --
 *
 *      This function tests whether the two paths given are equal path
Changes to generic/tclInt.decls.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tclInt.decls,v 1.34.2.2 2002/06/10 05:33:12 wolfsuit Exp $

library tcl

# Define the unsupported generic interfaces.

interface tclInt








|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: tclInt.decls,v 1.34.2.3 2002/08/20 20:25:26 das Exp $

library tcl

# Define the unsupported generic interfaces.

interface tclInt

126
127
128
129
130
131
132

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
declare 27 generic {
    int TclGetDate(char *p, unsigned long now, long zone,
	    unsigned long *timePtr)
}
declare 28 generic {
    Tcl_Channel TclpGetDefaultStdChannel(int type)
}

declare 29 generic {
    Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
	    int localIndex, Tcl_Obj *elemPtr, int flags)
}

# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
#  declare 30 generic {
#      char * TclGetEnv(CONST char *name)
#  }
declare 31 generic {
    char * TclGetExtension(char *name)
}
declare 32 generic {
    int TclGetFrame(Tcl_Interp *interp, CONST char *str,
	    CallFrame **framePtrPtr)
}
declare 33 generic {
    TclCmdProcType TclGetInterpProc(void)
}
declare 34 generic {
    int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    int endValue, int *indexPtr)
}

declare 35 generic {
    Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
	    int flags)
}

declare 36 generic {
    int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr)
}
declare 37 generic {
    int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
}
declare 38 generic {







>
|
|
|
<
>


















>
|
|
|
<
>







126
127
128
129
130
131
132
133
134
135
136

137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

160
161
162
163
164
165
166
167
declare 27 generic {
    int TclGetDate(char *p, unsigned long now, long zone,
	    unsigned long *timePtr)
}
declare 28 generic {
    Tcl_Channel TclpGetDefaultStdChannel(int type)
}
# Removed in 8.4b2:
#declare 29 generic {
#    Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
#	    int localIndex, Tcl_Obj *elemPtr, int flags)

#}
# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
#  declare 30 generic {
#      char * TclGetEnv(CONST char *name)
#  }
declare 31 generic {
    char * TclGetExtension(char *name)
}
declare 32 generic {
    int TclGetFrame(Tcl_Interp *interp, CONST char *str,
	    CallFrame **framePtrPtr)
}
declare 33 generic {
    TclCmdProcType TclGetInterpProc(void)
}
declare 34 generic {
    int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    int endValue, int *indexPtr)
}
# Removed in 8.4b2:
#declare 35 generic {
#    Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    int flags)

#}
declare 36 generic {
    int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr)
}
declare 37 generic {
    int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
}
declare 38 generic {
177
178
179
180
181
182
183
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
declare 41 generic {
    Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 generic {
    char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
}
declare 43 generic {
    int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags)
}
declare 44 generic {
    int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr)
}
declare 45 generic {
    int TclHideUnsafeCommands(Tcl_Interp *interp)
}
declare 46 generic {
    int TclInExit(void)
}

declare 47 generic {
    Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp,
	    int localIndex, Tcl_Obj *elemPtr, long incrAmount)
}


declare 48 generic {
    Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
	    long incrAmount)
}

declare 49 generic {
    Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
	    Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
}
declare 50 generic {
    void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
	    Namespace *nsPtr)
}
declare 51 generic {
    int TclInterpInit(Tcl_Interp *interp)
}
declare 52 generic {
    int TclInvoke(Tcl_Interp *interp, int argc, char **argv, int flags)
}
declare 53 generic {
    int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
	    int argc, char **argv)
}
declare 54 generic {
    int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
	    int objc, Tcl_Obj *CONST objv[])
}
declare 55 generic {
    Proc * TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
#  declare 56 generic {
#      int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
#  	    char *sym2, Tcl_PackageInitProc **proc1Ptr,
#  	    Tcl_PackageInitProc **proc2Ptr)
#  }
# Signature changed to take a length in 8.1:
#  declare 57 generic {
#      int TclLooksLikeInt(char *p)
#  }
declare 58 generic {
    Var * TclLookupVar(Tcl_Interp *interp, char *part1, CONST char *part2,
	    int flags, char *msg, int createPart1, int createPart2,
	    Var **arrayPtrPtr)
}
# Replaced by Tcl_FSMatchInDirectory in 8.4
#declare 59 generic {
#    int TclpMatchFiles(Tcl_Interp *interp, char *separators,
#	    Tcl_DString *dirPtr, char *pattern, char *tail)
#}







|










>
|
|
|
<
>
>
|
|
|
<
>












|



|



















|
|







179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200

201
202
203
204
205

206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
declare 41 generic {
    Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 generic {
    char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
}
declare 43 generic {
    int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 44 generic {
    int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr)
}
declare 45 generic {
    int TclHideUnsafeCommands(Tcl_Interp *interp)
}
declare 46 generic {
    int TclInExit(void)
}
# Removed in 8.4b2:
#declare 47 generic {
#    Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp,
#	    int localIndex, Tcl_Obj *elemPtr, long incrAmount)

#}
# Removed in 8.4b2:
#declare 48 generic {
#    Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    long incrAmount)

#}
declare 49 generic {
    Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
	    Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
}
declare 50 generic {
    void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
	    Namespace *nsPtr)
}
declare 51 generic {
    int TclInterpInit(Tcl_Interp *interp)
}
declare 52 generic {
    int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 53 generic {
    int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
	    int argc, CONST84 char **argv)
}
declare 54 generic {
    int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
	    int objc, Tcl_Obj *CONST objv[])
}
declare 55 generic {
    Proc * TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
#  declare 56 generic {
#      int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
#  	    char *sym2, Tcl_PackageInitProc **proc1Ptr,
#  	    Tcl_PackageInitProc **proc2Ptr)
#  }
# Signature changed to take a length in 8.1:
#  declare 57 generic {
#      int TclLooksLikeInt(char *p)
#  }
declare 58 generic {
    Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
	    int flags, CONST char *msg, int createPart1, int createPart2,
	    Var **arrayPtrPtr)
}
# Replaced by Tcl_FSMatchInDirectory in 8.4
#declare 59 generic {
#    int TclpMatchFiles(Tcl_Interp *interp, char *separators,
#	    Tcl_DString *dirPtr, char *pattern, char *tail)
#}
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
#  	    int flags, char **termPtr, ParseValue *pvPtr)
#  }
#  declare 87 generic {
#      void TclPlatformInit(Tcl_Interp *interp)
#  }
declare 88 generic {
    char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
	    char *name1, CONST char *name2, int flags)
}
declare 89 generic {
    int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
	    Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
#  declare 90 generic {







|







347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
#  	    int flags, char **termPtr, ParseValue *pvPtr)
#  }
#  declare 87 generic {
#      void TclPlatformInit(Tcl_Interp *interp)
#  }
declare 88 generic {
    char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
	    CONST char *name1, CONST char *name2, int flags)
}
declare 89 generic {
    int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
	    Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
#  declare 90 generic {
366
367
368
369
370
371
372
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
	    CONST char *procName)
}
declare 93 generic {
    void TclProcDeleteProc(ClientData clientData)
}
declare 94 generic {
    int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
	    int argc, char **argv)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 95 generic {
#    int TclpStat(CONST char *path, Tcl_StatBuf *buf)
#}
declare 96 generic {
    int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName)
}
declare 97 generic {
    void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
}
declare 98 generic {
    int TclServiceIdle(void)
}

declare 99 generic {
    Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
	    Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
}


declare 100 generic {
    Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
	    Tcl_Obj *objPtr, int flags)
}

declare 101 {unix win} {
    char * TclSetPreInitScript(char *string)
}
declare 102 generic {
    void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 generic {







|














>
|
|
|
<
>
>
|
|
|
<
>







370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395

396
397
398
399
400

401
402
403
404
405
406
407
408
	    CONST char *procName)
}
declare 93 generic {
    void TclProcDeleteProc(ClientData clientData)
}
declare 94 generic {
    int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
	    int argc, CONST84 char **argv)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 95 generic {
#    int TclpStat(CONST char *path, Tcl_StatBuf *buf)
#}
declare 96 generic {
    int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName)
}
declare 97 generic {
    void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
}
declare 98 generic {
    int TclServiceIdle(void)
}
# Removed in 8.4b2:
#declare 99 generic {
#    Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
#	    Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)

#}
# Removed in 8.4b2:
#declare 100 generic {
#    Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
#	    Tcl_Obj *objPtr, int flags)

#}
declare 101 {unix win} {
    char * TclSetPreInitScript(char *string)
}
declare 102 generic {
    void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 generic {
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
	    Tcl_ResolverInfo *resInfo)
}
declare 119 generic {
    int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
	    Tcl_ResolverInfo *resInfo)
}
declare 120 generic {
    Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name,
	    Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 generic {
    int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
	    CONST char *pattern)
}
declare 122 generic {







|







469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
	    Tcl_ResolverInfo *resInfo)
}
declare 119 generic {
    int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
	    Tcl_ResolverInfo *resInfo)
}
declare 120 generic {
    Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, CONST char *name,
	    Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 generic {
    int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
	    CONST char *pattern)
}
declare 122 generic {
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552

# Added in 8.1:

#declare 137 generic {
#   int TclpChdir(CONST char *dirName)
#}
declare 138 generic {
    CONST 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 {
    CONST char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 generic {
    int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CompileHookProc *hookProc, ClientData clientData)
}
declare 143 generic {
    int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,







|











|







532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558

# Added in 8.1:

#declare 137 generic {
#   int TclpChdir(CONST char *dirName)
#}
declare 138 generic {
    CONST84_RETURN char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
}
#declare 139 generic {
#    int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
#	    char *sym2, Tcl_PackageInitProc **proc1Ptr,
#	    Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
#}
declare 140 generic {
    int TclLooksLikeInt(CONST char *bytes, int length)
}
# This is used by TclX, but should otherwise be considered private
declare 141 generic {
    CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 generic {
    int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CompileHookProc *hookProc, ClientData clientData)
}
declare 143 generic {
    int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
#}

declare 156 generic {
    void TclRegError (Tcl_Interp *interp, CONST char *msg,
	    int status)
}
declare 157 generic {
    Var * TclVarTraceExists (Tcl_Interp *interp, char *varName)
}
declare 158 generic {
    void TclSetStartupScriptFileName(CONST char *filename)
}
declare 159 generic {
    CONST char *TclGetStartupScriptFileName(void)
}
#declare 160 generic {
#    int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
#	    Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
#}

# new in 8.3.2/8.4a2







|





|







610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
#}

declare 156 generic {
    void TclRegError (Tcl_Interp *interp, CONST char *msg,
	    int status)
}
declare 157 generic {
    Var * TclVarTraceExists (Tcl_Interp *interp, CONST char *varName)
}
declare 158 generic {
    void TclSetStartupScriptFileName(CONST char *filename)
}
declare 159 generic {
    CONST84_RETURN char *TclGetStartupScriptFileName(void)
}
#declare 160 generic {
#    int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
#	    Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
#}

# new in 8.3.2/8.4a2
661
662
663
664
665
666
667
668
669
670
671
672




673





674
675
676
677
678
679
680
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
declare 167 generic {
    void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
declare 168 generic {
    Tcl_Obj *TclGetStartupScriptPath(void)
}

# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 generic {
    int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n)
}











##############################################################################

# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.

interface tclIntPlat







<




>
>
>
>
|
>
>
>
>
>







667
668
669
670
671
672
673

674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
declare 167 generic {
    void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
declare 168 generic {
    Tcl_Obj *TclGetStartupScriptPath(void)
}

# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 generic {
    int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n)
}
declare 170 generic {
    int TclCheckInterpTraces (Tcl_Interp *interp, CONST char *command, int numChars, \
            Command *cmdPtr, int result, int traceFlags, int objc, \
	    Tcl_Obj *CONST objv[])
}
declare 171 generic {
    int TclCheckExecutionTraces (Tcl_Interp *interp, CONST char *command, int numChars, \
            Command *cmdPtr, int result, int traceFlags, int objc, \
	    Tcl_Obj *CONST objv[])
}

##############################################################################

# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.

interface tclIntPlat
935
936
937
938
939
940
941
942


















}

# Added in 8.1:

declare 9 unix {
    TclFile TclpCreateTempFile(CONST char *contents)
}



























>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
}

# Added in 8.1:

declare 9 unix {
    TclFile TclpCreateTempFile(CONST char *contents)
}

# Added in 8.4:

declare 10 unix {
    Tcl_DirEntry * TclpReaddir(DIR * dir)
}

declare 11 unix {
    struct tm * TclpLocaltime(time_t * clock)
}

declare 12 unix {
    struct tm * TclpGmtime(time_t * clock)
}

declare 13 unix {
    char * TclpInetNtoa(struct in_addr addr)
}

Changes to generic/tclInt.h.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.68.2.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.68.2.3 2002/08/20 20:25:26 das Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
    Tcl_ResolveRuntimeVarProc *fetchProc;
    Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;



typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, char* name, int length,
    Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr));

typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, char* name, Tcl_Namespace *context,
    int flags, Tcl_Var *rPtr));

typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
    CONST84 char* name, Tcl_Namespace *context, int flags,
    Tcl_Command *rPtr));
 
typedef struct Tcl_ResolverInfo {







|



|







87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
    Tcl_ResolveRuntimeVarProc *fetchProc;
    Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;



typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, CONST84 char* name, int length,
    Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr));

typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
    Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context,
    int flags, Tcl_Var *rPtr));

typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
    CONST84 char* name, Tcl_Namespace *context, int flags,
    Tcl_Command *rPtr));
 
typedef struct Tcl_ResolverInfo {
285
286
287
288
289
290
291








292
293
294
295
296
297
298
299
300
301
302
    int flags;			    /* What events the trace procedure is
				     * interested in:  OR-ed combination of
				     * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;   /* Next in list of traces associated with
				     * a particular command. */
} CommandTrace;









typedef struct ActiveCommandTrace {
    struct Command *cmdPtr;	/* Variable that's being traced. */
    struct ActiveCommandTrace *nextPtr;
				/* Next in list of all active variable
				 * traces for the interpreter, or NULL
				 * if no more. */
    CommandTrace *nextTracePtr;	/* Next trace to check after current
				 * trace procedure returns;  if this
				 * trace gets deleted, must update pointer
				 * to avoid using free'd memory. */
} ActiveCommandTrace;







>
>
>
>
>
>
>
>

|

|







285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
    int flags;			    /* What events the trace procedure is
				     * interested in:  OR-ed combination of
				     * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    struct CommandTrace *nextPtr;   /* Next in list of traces associated with
				     * a particular command. */
} CommandTrace;

/*
 * When a command trace is active (i.e. its associated procedure is
 * executing), one of the following structures is linked into a list
 * associated with the command's interpreter.  The information in
 * the structure is needed in order for Tcl to behave reasonably
 * if traces are deleted while traces are active.
 */

typedef struct ActiveCommandTrace {
    struct Command *cmdPtr;	/* Command that's being traced. */
    struct ActiveCommandTrace *nextPtr;
				/* Next in list of all active command
				 * traces for the interpreter, or NULL
				 * if no more. */
    CommandTrace *nextTracePtr;	/* Next trace to check after current
				 * trace procedure returns;  if this
				 * trace gets deleted, must update pointer
				 * to avoid using free'd memory. */
} ActiveCommandTrace;
651
652
653
654
655
656
657



















658
659
660
661
662
663
664
    struct Trace *nextPtr;	/* Next in list of traces for this interp. */
    int flags;			/* Flags governing the trace - see
				 * Tcl_CreateObjTrace for details */
    Tcl_CmdObjTraceDeleteProc* delProc;
				/* Procedure to call when trace is deleted */
} Trace;




















/*
 * The structure below defines an entry in the assocData hash table which
 * is associated with an interpreter. The entry contains a pointer to a
 * function to call when the interpreter is deleted, and a pointer to
 * a user-defined piece of data.
 */








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
    struct Trace *nextPtr;	/* Next in list of traces for this interp. */
    int flags;			/* Flags governing the trace - see
				 * Tcl_CreateObjTrace for details */
    Tcl_CmdObjTraceDeleteProc* delProc;
				/* Procedure to call when trace is deleted */
} Trace;

/*
 * When an interpreter trace is active (i.e. its associated procedure
 * is executing), one of the following structures is linked into a list
 * associated with the interpreter.  The information in the structure
 * is needed in order for Tcl to behave reasonably if traces are
 * deleted while traces are active.
 */

typedef struct ActiveInterpTrace {
    struct ActiveInterpTrace *nextPtr;
				/* Next in list of all active command
				 * traces for the interpreter, or NULL
				 * if no more. */
    Trace *nextTracePtr;	/* Next trace to check after current
				 * trace procedure returns;  if this
				 * trace gets deleted, must update pointer
				 * to avoid using free'd memory. */
} ActiveInterpTrace;

/*
 * The structure below defines an entry in the assocData hash table which
 * is associated with an interpreter. The entry contains a pointer to a
 * function to call when the interpreter is deleted, and a pointer to
 * a user-defined piece of data.
 */

733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
 * are a very lightweight method of preserving enough information
 * to determine if an arbitrary malloc'd block has been deleted.
 *----------------------------------------------------------------
 */

typedef VOID **TclHandle;

EXTERN TclHandle	TclHandleCreate _ANSI_ARGS_((VOID *ptr));
EXTERN void		TclHandleFree _ANSI_ARGS_((TclHandle handle));
EXTERN TclHandle	TclHandlePreserve _ANSI_ARGS_((TclHandle handle));
EXTERN void		TclHandleRelease _ANSI_ARGS_((TclHandle handle)); 

/*
 *----------------------------------------------------------------
 * Data structures related to history.	 These are used primarily
 * in tclHistory.c
 *----------------------------------------------------------------
 */








<
<
<
<
<







760
761
762
763
764
765
766





767
768
769
770
771
772
773
 * are a very lightweight method of preserving enough information
 * to determine if an arbitrary malloc'd block has been deleted.
 *----------------------------------------------------------------
 */

typedef VOID **TclHandle;






/*
 *----------------------------------------------------------------
 * Data structures related to history.	 These are used primarily
 * in tclHistory.c
 *----------------------------------------------------------------
 */

884
885
886
887
888
889
890


891
892
893
894
895
896
897

typedef struct ExecEnv {
    Tcl_Obj **stackPtr;		/* Points to the first item in the
				 * evaluation stack on the heap. */
    int stackTop;		/* Index of current top of stack; -1 when
				 * the stack is empty. */
    int stackEnd;		/* Index of last usable item in stack. */


} ExecEnv;

/*
 * The definitions for the LiteralTable and LiteralEntry structures. Each
 * interpreter contains a LiteralTable. It is used to reduce the storage
 * needed for all the Tcl objects that hold the literals of scripts compiled
 * by the interpreter. A literal's object is shared by all the ByteCodes







>
>







906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921

typedef struct ExecEnv {
    Tcl_Obj **stackPtr;		/* Points to the first item in the
				 * evaluation stack on the heap. */
    int stackTop;		/* Index of current top of stack; -1 when
				 * the stack is empty. */
    int stackEnd;		/* Index of last usable item in stack. */
    Tcl_Obj *errorInfo;
    Tcl_Obj *errorCode;
} ExecEnv;

/*
 * The definitions for the LiteralTable and LiteralEntry structures. Each
 * interpreter contains a LiteralTable. It is used to reduce the storage
 * needed for all the Tcl objects that hold the literals of scripts compiled
 * by the interpreter. A literal's object is shared by all the ByteCodes
1076
1077
1078
1079
1080
1081
1082



1083
1084
1085
1086
1087
1088
1089
1090

1091
1092
1093
1094
1095
1096
1097
 *                              of being deleted (its deleteProc is
 *                              currently executing). Other attempts to
 *                              delete the command should be ignored.
 * CMD_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a rename/delete change.
 *				See the two flags below for which is
 *				currently being processed.



 * TCL_TRACE_RENAME -           A rename trace is in progress. Further
 *                              recursive renames will not be traced.
 * TCL_TRACE_DELETE -           A delete trace is in progress. Further 
 *                              recursive deletes will not be traced.
 * (these last two flags are defined in tcl.h)
 */
#define CMD_IS_DELETED		0x1
#define CMD_TRACE_ACTIVE	0x2


/*
 *----------------------------------------------------------------
 * Data structures related to name resolution procedures.
 *----------------------------------------------------------------
 */








>
>
>








>







1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
 *                              of being deleted (its deleteProc is
 *                              currently executing). Other attempts to
 *                              delete the command should be ignored.
 * CMD_TRACE_ACTIVE -		1 means that trace processing is currently
 *				underway for a rename/delete change.
 *				See the two flags below for which is
 *				currently being processed.
 * CMD_HAS_EXEC_TRACES -	1 means that this command has at least
 *                              one execution trace (as opposed to simple
 *                              delete/rename traces) in its tracePtr list.
 * TCL_TRACE_RENAME -           A rename trace is in progress. Further
 *                              recursive renames will not be traced.
 * TCL_TRACE_DELETE -           A delete trace is in progress. Further 
 *                              recursive deletes will not be traced.
 * (these last two flags are defined in tcl.h)
 */
#define CMD_IS_DELETED		0x1
#define CMD_TRACE_ACTIVE	0x2
#define CMD_HAS_EXEC_TRACES	0x4

/*
 *----------------------------------------------------------------
 * Data structures related to name resolution procedures.
 *----------------------------------------------------------------
 */

1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
				 * 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 *activeTracePtr;
				/* First in list of active traces for
				 * interp, or NULL if no active traces. */
    int returnCode;		/* Completion code to return if current
				 * procedure exits with TCL_RETURN code. */
    char *errorInfo;		/* Value to store in errorInfo if returnCode
				 * is TCL_ERROR.  Malloc'ed, may be NULL */
    char *errorCode;		/* Value to store in errorCode if returnCode







|







1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
				 * procedure invocations.  NULL means there
				 * are no active procedures. */
    CallFrame *varFramePtr;	/* Points to the call frame whose variables
				 * are currently in use (same as framePtr
				 * unless an "uplevel" command is
				 * executing). NULL means no procedure is
				 * active or "uplevel 0" is executing. */
    ActiveVarTrace *activeVarTracePtr;
				/* First in list of active traces for
				 * interp, or NULL if no active traces. */
    int returnCode;		/* Completion code to return if current
				 * procedure exits with TCL_RETURN code. */
    char *errorInfo;		/* Value to store in errorInfo if returnCode
				 * is TCL_ERROR.  Malloc'ed, may be NULL */
    char *errorCode;		/* Value to store in errorCode if returnCode
1301
1302
1303
1304
1305
1306
1307



1308
1309
1310
1311
1312
1313
1314
				 * result, this points to it. Should not be
				 * accessed directly; see comment above. */
    Tcl_ThreadId threadId;	/* ID of thread that owns the interpreter */

    ActiveCommandTrace *activeCmdTracePtr;
				/* First in list of active command traces for
				 * interp, or NULL if no active traces. */




    int tracesForbiddingInline; /* Count of traces (in the list headed by
				 * tracePtr) that forbid inline bytecode
				 * compilation */
    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation.







>
>
>







1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
				 * result, this points to it. Should not be
				 * accessed directly; see comment above. */
    Tcl_ThreadId threadId;	/* ID of thread that owns the interpreter */

    ActiveCommandTrace *activeCmdTracePtr;
				/* First in list of active command traces for
				 * interp, or NULL if no active traces. */
    ActiveInterpTrace *activeInterpTracePtr;
				/* First in list of active traces for
				 * interp, or NULL if no active traces. */

    int tracesForbiddingInline; /* Count of traces (in the list headed by
				 * tracePtr) that forbid inline bytecode
				 * compilation */
    /*
     * Statistical information about the bytecode compiler and interpreter's
     * operation.
1363
1364
1365
1366
1367
1368
1369



1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380

1381
1382
1383
1384
1385
1386
1387
 * SAFE_INTERP:		Non zero means that the current interp is a
 *			safe interp (ie it has only the safe commands
 *			installed, less priviledge than a regular interp).
 * USE_EVAL_DIRECT:	Non-zero means don't use the compiler or byte-code
 *			interpreter; instead, have Tcl_EvalObj call
 *			Tcl_EvalEx. Used primarily for testing the
 *			new parser.



 */

#define DELETED				    1
#define ERR_IN_PROGRESS			    2
#define ERR_ALREADY_LOGGED		    4
#define ERROR_CODE_SET			    8
#define EXPR_INITIALIZED		 0x10
#define DONT_COMPILE_CMDS_INLINE	 0x20
#define RAND_SEED_INITIALIZED		 0x40
#define SAFE_INTERP			 0x80
#define USE_EVAL_DIRECT			0x100


/*
 *----------------------------------------------------------------
 * Data structures related to command parsing. These are used in
 * tclParse.c and its clients.
 *----------------------------------------------------------------
 */







>
>
>











>







1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
 * SAFE_INTERP:		Non zero means that the current interp is a
 *			safe interp (ie it has only the safe commands
 *			installed, less priviledge than a regular interp).
 * USE_EVAL_DIRECT:	Non-zero means don't use the compiler or byte-code
 *			interpreter; instead, have Tcl_EvalObj call
 *			Tcl_EvalEx. Used primarily for testing the
 *			new parser.
 * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
 *			active; so no further trace callbacks should be
 *			invoked.
 */

#define DELETED				    1
#define ERR_IN_PROGRESS			    2
#define ERR_ALREADY_LOGGED		    4
#define ERROR_CODE_SET			    8
#define EXPR_INITIALIZED		 0x10
#define DONT_COMPILE_CMDS_INLINE	 0x20
#define RAND_SEED_INITIALIZED		 0x40
#define SAFE_INTERP			 0x80
#define USE_EVAL_DIRECT			0x100
#define INTERP_TRACE_IN_PROGRESS	0x200

/*
 *----------------------------------------------------------------
 * Data structures related to command parsing. These are used in
 * tclParse.c and its clients.
 *----------------------------------------------------------------
 */
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538

typedef struct TclFile_ *TclFile;
    
/*
 * Opaque names for platform specific types.
 */

typedef struct TclpTime_t_ *TclpTime_t;

/*
 * The "globParameters" argument of the function TclGlob is an
 * or'ed combination of the following values:
 */

#define TCL_GLOBMODE_NO_COMPLAIN      1







|







1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573

typedef struct TclFile_ *TclFile;
    
/*
 * Opaque names for platform specific types.
 */

typedef struct TclpTime_t_    *TclpTime_t;

/*
 * The "globParameters" argument of the function TclGlob is an
 * or'ed combination of the following values:
 */

#define TCL_GLOBMODE_NO_COMPLAIN      1
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572

/*
 *----------------------------------------------------------------
 * Data structures related to procedures
 *----------------------------------------------------------------
 */

typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int argc, char *argv[]));
typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData,
	Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));

/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */








|
<
|
<







1590
1591
1592
1593
1594
1595
1596
1597

1598

1599
1600
1601
1602
1603
1604
1605

/*
 *----------------------------------------------------------------
 * Data structures related to procedures
 *----------------------------------------------------------------
 */

typedef Tcl_CmdProc *TclCmdProcType;

typedef Tcl_ObjCmdProc *TclObjCmdProcType;


/*
 *----------------------------------------------------------------
 * Variables shared among Tcl modules but not used by the outside world.
 *----------------------------------------------------------------
 */

1634
1635
1636
1637
1638
1639
1640
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
/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl modules but not used by the outside
 * world:
 *----------------------------------------------------------------
 */

EXTERN int		TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN int		TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN void		TclAllocateFreeObjects _ANSI_ARGS_((void));
EXTERN int		TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int		TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *value));
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
			    int numPids, Tcl_Pid *pidPtr,
			    Tcl_Channel errorChan));
EXTERN void		TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr));
EXTERN int		TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Channel inChan, Tcl_Channel outChan,
			    int toRead, Tcl_Obj *cmdPtr));
EXTERN int		TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp,
			    Namespace *nsPtr, CONST char *procName,
			    Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
			    Proc **procPtrPtr));
EXTERN void		TclDeleteCompiledLocalVars _ANSI_ARGS_((
			    Interp *iPtr, CallFrame *framePtr));
EXTERN void		TclDeleteVars _ANSI_ARGS_((Interp *iPtr,
			    Tcl_HashTable *tablePtr));
EXTERN int		TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp,
			    char *separators, Tcl_DString *headPtr,
			    char *tail, Tcl_GlobTypeData *types));
EXTERN void		TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile));
EXTERN void		TclExpandTokenArray _ANSI_ARGS_((
			    Tcl_Parse *parsePtr));
EXTERN void		TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
			    double value));
EXTERN int		TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
EXTERN int		TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, 
			    int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int		TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
EXTERN int		TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,







<
<
<




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


<
<







1667
1668
1669
1670
1671
1672
1673



1674
1675
1676
1677



















1678
1679


1680
1681
1682
1683
1684
1685
1686
/*
 *----------------------------------------------------------------
 * Procedures shared among Tcl modules but not used by the outside
 * world:
 *----------------------------------------------------------------
 */




EXTERN int		TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int		TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *value));



















EXTERN void		TclExpandTokenArray _ANSI_ARGS_((
			    Tcl_Parse *parsePtr));


EXTERN int		TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
EXTERN int		TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, 
			    int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int		TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
EXTERN int		TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
1689
1690
1691
1692
1693
1694
1695
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
EXTERN void		TclFinalizeLoad _ANSI_ARGS_((void));
EXTERN void		TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
EXTERN void		TclFinalizeNotifier _ANSI_ARGS_((void));
EXTERN void		TclFinalizeAsync _ANSI_ARGS_((void));
EXTERN void		TclFinalizeSynchronization _ANSI_ARGS_((void));
EXTERN void		TclFinalizeThreadData _ANSI_ARGS_((void));
EXTERN void		TclFindEncodings _ANSI_ARGS_((CONST char *argv0));
EXTERN int		TclFormatInt _ANSI_ARGS_((char *buffer, long n));
EXTERN void		TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr));
EXTERN int		TclGetDate _ANSI_ARGS_((char *p,
			    unsigned long now, long zone,
			    unsigned long *timePtr));
EXTERN Tcl_Obj *	TclGetElementOfIndexedArray _ANSI_ARGS_((
			    Tcl_Interp *interp, int localIndex,
			    Tcl_Obj *elemPtr, int flags));
EXTERN char *		TclGetExtension _ANSI_ARGS_((char *name));
EXTERN TclCmdProcType	TclGetInterpProc _ANSI_ARGS_((void));
EXTERN int		TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr, int endValue, int *indexPtr));
EXTERN Tcl_Obj *	TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
			    int localIndex, int flags));
EXTERN int		TclGetLoadedPackages _ANSI_ARGS_((
			    Tcl_Interp *interp, char *targetName));
EXTERN int		TclGetNamespaceForQualName _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *qualName,
			    Namespace *cxtNsPtr, int flags,
			    Namespace **nsPtrPtr, Namespace **altNsPtrPtr,
			    Namespace **actualCxtPtrPtr,
			    CONST char **simpleNamePtr));
EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
EXTERN Tcl_Command	TclGetOriginalCommand _ANSI_ARGS_((
			    Tcl_Command command));
EXTERN int		TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
			    char *pattern, Tcl_Obj *unquotedPrefix, 
			    int globFlags, Tcl_GlobTypeData* types));
EXTERN int		TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp,
			    int argc, char **argv, int flags));
EXTERN int		TclHideUnsafeCommands _ANSI_ARGS_((
			    Tcl_Interp *interp));
EXTERN int		TclInExit _ANSI_ARGS_((void));
EXTERN Tcl_Obj *	TclIncrElementOfIndexedArray _ANSI_ARGS_((
			    Tcl_Interp *interp, int localIndex,
			    Tcl_Obj *elemPtr, long incrAmount));
EXTERN Tcl_Obj *	TclIncrIndexedScalar _ANSI_ARGS_((
			    Tcl_Interp *interp, int localIndex,
			    long incrAmount));
EXTERN Tcl_Obj *	TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
			    long incrAmount, int flags));
EXTERN void		TclInitAlloc _ANSI_ARGS_((void));
EXTERN void		TclInitCompiledLocals _ANSI_ARGS_((
			    Tcl_Interp *interp, CallFrame *framePtr,
			    Namespace *nsPtr));
EXTERN void		TclInitDbCkalloc _ANSI_ARGS_((void));
EXTERN void		TclInitEncodingSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitIOSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitNamespaceSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitNotifier _ANSI_ARGS_((void));
EXTERN void		TclInitObjSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitSubsystems _ANSI_ARGS_((CONST char *argv0));
EXTERN int		TclInvoke _ANSI_ARGS_((Tcl_Interp *interp,
			    int argc, char **argv, int flags));
EXTERN int		TclInvokeObjectCommand _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int argc, char **argv));
EXTERN int		TclInvokeStringCommand _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
EXTERN int		TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
			    int len));
EXTERN Proc *		TclIsProc _ANSI_ARGS_((Command *cmdPtr));
EXTERN int              TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
			    int* result));
EXTERN Tcl_Obj *	TclLindexList _ANSI_ARGS_((Tcl_Interp* interp,
						   Tcl_Obj* listPtr,
						   Tcl_Obj* argPtr ));
EXTERN Tcl_Obj *	TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp,
						   Tcl_Obj* listPtr,







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<







<
<
<
<
<
<
<
<


<







1698
1699
1700
1701
1702
1703
1704

























1705
1706
1707














1708



1709
1710
1711
1712
1713
1714
1715








1716
1717

1718
1719
1720
1721
1722
1723
1724
EXTERN void		TclFinalizeLoad _ANSI_ARGS_((void));
EXTERN void		TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
EXTERN void		TclFinalizeNotifier _ANSI_ARGS_((void));
EXTERN void		TclFinalizeAsync _ANSI_ARGS_((void));
EXTERN void		TclFinalizeSynchronization _ANSI_ARGS_((void));
EXTERN void		TclFinalizeThreadData _ANSI_ARGS_((void));
EXTERN void		TclFindEncodings _ANSI_ARGS_((CONST char *argv0));

























EXTERN int		TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
			    char *pattern, Tcl_Obj *unquotedPrefix, 
			    int globFlags, Tcl_GlobTypeData* types));














EXTERN void		TclInitAlloc _ANSI_ARGS_((void));



EXTERN void		TclInitDbCkalloc _ANSI_ARGS_((void));
EXTERN void		TclInitEncodingSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitIOSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitNamespaceSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitNotifier _ANSI_ARGS_((void));
EXTERN void		TclInitObjSubsystem _ANSI_ARGS_((void));
EXTERN void		TclInitSubsystems _ANSI_ARGS_((CONST char *argv0));








EXTERN int		TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
			    int len));

EXTERN int              TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
			    int* result));
EXTERN Tcl_Obj *	TclLindexList _ANSI_ARGS_((Tcl_Interp* interp,
						   Tcl_Obj* listPtr,
						   Tcl_Obj* argPtr ));
EXTERN Tcl_Obj *	TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp,
						   Tcl_Obj* listPtr,
1774
1775
1776
1777
1778
1779
1780
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
						 ));
EXTERN Tcl_Obj *	TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
						 Tcl_Obj* listPtr,
						 int indexCount,
						 Tcl_Obj *CONST indexArray[],
						 Tcl_Obj* valuePtr
						 ));
EXTERN Tcl_Obj *	TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr));
EXTERN int		TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr));
EXTERN int		TclObjInterpProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
EXTERN int		TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int flags));
EXTERN int		TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[], int flags));
EXTERN int		TclOpenFileChannelDeleteProc _ANSI_ARGS_((
			    TclOpenFileChannelProc_ *proc));
EXTERN int		TclOpenFileChannelInsertProc _ANSI_ARGS_((
			    TclOpenFileChannelProc_ *proc));
EXTERN int		TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
			    int mode));
EXTERN int              TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    Tcl_StatBuf *buf));
EXTERN char *		TclpAlloc _ANSI_ARGS_((unsigned int size));
EXTERN int		TclpCheckStackSpace _ANSI_ARGS_((void));
EXTERN Tcl_Obj*         TclpTempFileName _ANSI_ARGS_((void));
EXTERN void		TclpExit _ANSI_ARGS_((int status));
EXTERN void		TclpFinalizeCondition _ANSI_ARGS_((
			    Tcl_Condition *condPtr));
EXTERN void		TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void		TclpFinalizeThreadData _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpFinalizeThreadDataKey _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN char *		TclpFindExecutable _ANSI_ARGS_((
			    CONST char *argv0));
EXTERN int		TclpFindVariable _ANSI_ARGS_((CONST char *name,
			    int *lengthPtr));
EXTERN void		TclpFree _ANSI_ARGS_((char *ptr));
EXTERN unsigned long	TclpGetClicks _ANSI_ARGS_((void));
EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN unsigned long	TclpGetSeconds _ANSI_ARGS_((void));
EXTERN int		TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char *		TclpGetUserHome _ANSI_ARGS_((CONST char *name,
			    Tcl_DString *bufferPtr));
EXTERN int		TclpHasSockets _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void		TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
EXTERN void		TclpInitLock _ANSI_ARGS_((void));
EXTERN void		TclpInitPlatform _ANSI_ARGS_((void));
EXTERN void		TclpInitUnlock _ANSI_ARGS_((void));
EXTERN int              TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, 
				Tcl_Obj *pathPtr,
				CONST char *sym1, CONST char *sym2, 







|
|
|
<
|
|
|
|
|
<
<
<
<




<


<











<
<
<
<
<
<
<
<







1732
1733
1734
1735
1736
1737
1738
1739
1740
1741

1742
1743
1744
1745
1746




1747
1748
1749
1750

1751
1752

1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763








1764
1765
1766
1767
1768
1769
1770
						 ));
EXTERN Tcl_Obj *	TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
						 Tcl_Obj* listPtr,
						 int indexCount,
						 Tcl_Obj *CONST indexArray[],
						 Tcl_Obj* valuePtr
						 ));
EXTERN int              TclParseBackslash _ANSI_ARGS_((CONST char *src,
                            int numBytes, int *readPtr, char *dst));
EXTERN int		TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,

                            Tcl_UniChar *resultPtr));
EXTERN int		TclParseInteger _ANSI_ARGS_((CONST char *string,
			    int numBytes));
EXTERN int		TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
			    int numBytes, Tcl_Parse *parsePtr, char *typePtr));




EXTERN int		TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
			    int mode));
EXTERN int              TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, 
			    Tcl_StatBuf *buf));

EXTERN int		TclpCheckStackSpace _ANSI_ARGS_((void));
EXTERN Tcl_Obj*         TclpTempFileName _ANSI_ARGS_((void));

EXTERN void		TclpFinalizeCondition _ANSI_ARGS_((
			    Tcl_Condition *condPtr));
EXTERN void		TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void		TclpFinalizeThreadData _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpFinalizeThreadDataKey _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN char *		TclpFindExecutable _ANSI_ARGS_((
			    CONST char *argv0));
EXTERN int		TclpFindVariable _ANSI_ARGS_((CONST char *name,
			    int *lengthPtr));








EXTERN void		TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
EXTERN void		TclpInitLock _ANSI_ARGS_((void));
EXTERN void		TclpInitPlatform _ANSI_ARGS_((void));
EXTERN void		TclpInitUnlock _ANSI_ARGS_((void));
EXTERN int              TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, 
				Tcl_Obj *pathPtr,
				CONST char *sym1, CONST char *sym2, 
1855
1856
1857
1858
1859
1860
1861
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
				int recursive, Tcl_Obj **errorPtr));
EXTERN int		TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, 
				Tcl_Obj *destPathPtr));
EXTERN int		TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, 
			        Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, 
				CONST char *pattern, Tcl_GlobTypeData *types));
EXTERN Tcl_Obj*		TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN Tcl_Obj*		TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr));

EXTERN int		TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
EXTERN Tcl_Obj*         TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, 
						    Tcl_Obj*pathPtr));
EXTERN int		TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
EXTERN Tcl_Channel	TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, CONST char *modeString,
			    int permissions));
EXTERN void		TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,
			    format));
EXTERN char *		TclpReadlink _ANSI_ARGS_((CONST char *fileName,
			    Tcl_DString *linkPtr));
EXTERN char *		TclpRealloc _ANSI_ARGS_((char *ptr, unsigned int size));
EXTERN void		TclpReleaseFile _ANSI_ARGS_((TclFile file));
EXTERN void		TclpSetInitialEncodings _ANSI_ARGS_((void));
EXTERN void		TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN VOID *		TclpSysAlloc _ANSI_ARGS_((long size, int isBin));
EXTERN void		TclpSysFree _ANSI_ARGS_((VOID *ptr));
EXTERN VOID *		TclpSysRealloc _ANSI_ARGS_((VOID *cp,
			    unsigned int size));
EXTERN void		TclpUnloadFile _ANSI_ARGS_((ClientData clientData));
EXTERN int		TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Interp *cmdInterp, Tcl_Command cmd));
EXTERN void		TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr));
EXTERN int		TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
			    Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
			    CONST char *description, CONST char *procName));
EXTERN void		TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
EXTERN VOID *		TclpThreadDataKeyGet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpThreadDataKeyInit _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpThreadDataKeySet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr, VOID *data));
EXTERN void		TclpThreadExit _ANSI_ARGS_((int status));
EXTERN void		TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex));
EXTERN void		TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex));
EXTERN VOID             TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id));
EXTERN void		TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
EXTERN int		TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp,
			    char *oldName, char *newName)) ;
EXTERN void		TclResetShadowedCmdRefs _ANSI_ARGS_((
			    Tcl_Interp *interp, Command *newCmdPtr));
EXTERN int		TclServiceIdle _ANSI_ARGS_((void));
EXTERN Tcl_Obj *	TclSetElementOfIndexedArray _ANSI_ARGS_((
			    Tcl_Interp *interp, int localIndex,
			    Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags));
EXTERN Tcl_Obj *	TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
			    int localIndex, Tcl_Obj *objPtr, int flags));
EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char *string));
EXTERN void		TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN VOID             TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
			     int result));
EXTERN int		TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp,
			    char *string, char *proto, int *portPtr));
EXTERN int		TclSockMinimumBuffers _ANSI_ARGS_((int sock,
			    int size));
EXTERN int		TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc));
EXTERN int		TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc));
EXTERN void		TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr));
EXTERN void		TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
			    int result, Tcl_Interp *targetInterp));
EXTERN int		TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr));
EXTERN Tcl_Obj*         TclpNativeToNormalized 
                            _ANSI_ARGS_((ClientData clientData));
EXTERN Tcl_Obj*	TclpFilesystemPathType
					_ANSI_ARGS_((Tcl_Obj* pathObjPtr));







/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */








|
>





|





<

<

<
<
<
<
|
<
<
<
<
<
<
<











<
<
<
<
<
<
<
<
<
<
<
<


<
<
<
<
<
<
<


<


|

>
>
>
>
>
>







1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817

1818

1819




1820







1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831












1832
1833







1834
1835

1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
				int recursive, Tcl_Obj **errorPtr));
EXTERN int		TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, 
				Tcl_Obj *destPathPtr));
EXTERN int		TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, 
			        Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, 
				CONST char *pattern, Tcl_GlobTypeData *types));
EXTERN Tcl_Obj*		TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN Tcl_Obj*		TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, 
				Tcl_Obj *toPtr, int linkType));
EXTERN int		TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
EXTERN Tcl_Obj*         TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, 
						    Tcl_Obj*pathPtr));
EXTERN int		TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
EXTERN Tcl_Channel	TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *pathPtr, int mode,
			    int permissions));
EXTERN void		TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,
			    format));
EXTERN char *		TclpReadlink _ANSI_ARGS_((CONST char *fileName,
			    Tcl_DString *linkPtr));

EXTERN void		TclpReleaseFile _ANSI_ARGS_((TclFile file));

EXTERN void		TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));




EXTERN void		TclpUnloadFile _ANSI_ARGS_((Tcl_LoadHandle loadHandle));







EXTERN VOID *		TclpThreadDataKeyGet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpThreadDataKeyInit _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpThreadDataKeySet _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr, VOID *data));
EXTERN void		TclpThreadExit _ANSI_ARGS_((int status));
EXTERN void		TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex));
EXTERN void		TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex));
EXTERN VOID             TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id));
EXTERN void		TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));












EXTERN VOID             TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
			     int result));







EXTERN void		TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
			    int result, Tcl_Interp *targetInterp));

EXTERN Tcl_Obj*         TclpNativeToNormalized 
                            _ANSI_ARGS_((ClientData clientData));
EXTERN Tcl_Obj*	        TclpFilesystemPathType
					_ANSI_ARGS_((Tcl_Obj* pathObjPtr));
EXTERN Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_LoadHandle loadHandle, CONST char *symbol));
EXTERN int              TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, 
			    Tcl_Obj *pathPtr, 
	                    Tcl_LoadHandle *loadHandle, 
		            Tcl_FSUnloadFileProc **unloadProcPtr));

/*
 *----------------------------------------------------------------
 * Command procedures in the generic core:
 *----------------------------------------------------------------
 */

2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
 *----------------------------------------------------------------
 * Command procedures found only in the Mac version of the core:
 *----------------------------------------------------------------
 */

#ifdef MAC_TCL
EXTERN int	Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, char **argv));
EXTERN int	Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int	Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int	Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int	Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData,







|







2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
 *----------------------------------------------------------------
 * Command procedures found only in the Mac version of the core:
 *----------------------------------------------------------------
 */

#ifdef MAC_TCL
EXTERN int	Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, CONST84 char **argv));
EXTERN int	Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int	Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int	Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int	Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData,
2148
2149
2150
2151
2152
2153
2154
























2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169




2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
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
EXTERN int	TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int	TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int	TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));

























/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count,
 * and frees the object if its reference count is zero.
 * These macros are inline versions of Tcl_NewObj() and
 * Tcl_DecrRefCount(). Notice that the names differ in not having
 * a "_" after the "Tcl". Notice also that these macros reference
 * their argument more than once, so you should avoid calling them
 * with an expression that is expensive to compute or has
 * side effects. The ANSI C "prototypes" for these macros are:
 *
 * EXTERN void	TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
 * EXTERN void	TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));




 *----------------------------------------------------------------
 */

#ifdef TCL_COMPILE_STATS
#  define TclIncrObjsAllocated() \
    tclObjsAlloced++
#  define TclIncrObjsFreed() \
    tclObjsFreed++
#else
#  define TclIncrObjsAllocated()
#  define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */

#ifdef TCL_MEM_DEBUG
#  define TclNewObj(objPtr) \
    (objPtr) = (Tcl_Obj *) \
	 Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL; \
    TclIncrObjsAllocated()
     
#  define TclDbNewObj(objPtr, file, line) \
    (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL; \
    TclIncrObjsAllocated()
     
#  define TclDecrRefCount(objPtr) \
    if (--(objPtr)->refCount <= 0) { \
	if ((objPtr)->refCount < -1) \
	    panic("Reference count for %lx was negative: %s line %d", \
		  (objPtr), __FILE__, __LINE__); \
	if (((objPtr)->typePtr != NULL) \
		&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
	    (objPtr)->typePtr->freeIntRepProc(objPtr); \
	} \
	if (((objPtr)->bytes != NULL) \
		&& ((objPtr)->bytes != tclEmptyStringRep)) { \
	    ckfree((char *) (objPtr)->bytes); \
	} \
	ckfree((char *) (objPtr)); \
	TclIncrObjsFreed(); \
    }





















#elif defined(PURIFY)

/*
 * The PURIFY mode is like the regular mode, but instead of doing block
 * Tcl_Obj allocation and keeping a freed list for efficiency, it always
 * allocates and frees a single Tcl_Obj so that tools like Purify can
 * better track memory leaks
 */

#  define TclNewObj(objPtr) \
    (objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj)); \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL; \
    TclIncrObjsAllocated();

#  define TclDecrRefCount(objPtr) \
    if (--(objPtr)->refCount <= 0) { \
	if (((objPtr)->typePtr != NULL) \
		&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
	    (objPtr)->typePtr->freeIntRepProc(objPtr); \
	} \
	if (((objPtr)->bytes != NULL) \
		&& ((objPtr)->bytes != tclEmptyStringRep)) { \
	    ckfree((char *) (objPtr)->bytes); \
	} \
	ckfree((char *) (objPtr)); \
	TclIncrObjsFreed(); \
    }

#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
 * from per-thread caches.
 */

EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void));
EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));

#  define TclNewObj(objPtr) \
       (objPtr) = TclThreadAllocObj(); \
       (objPtr)->refCount = 0; \
       (objPtr)->bytes    = tclEmptyStringRep; \
       (objPtr)->length   = 0; \
       (objPtr)->typePtr  = NULL

#  define TclDecrRefCount(objPtr) \
       if (--(objPtr)->refCount <= 0) { \
           if (((objPtr)->bytes != NULL) \
                   && ((objPtr)->bytes != tclEmptyStringRep)) { \
               ckfree((char *) (objPtr)->bytes); \
           } \
           if (((objPtr)->typePtr != NULL) \
                   && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
               (objPtr)->typePtr->freeIntRepProc(objPtr); \
           } \
           TclThreadFreeObj((objPtr)); \
       }

#else /* not TCL_MEM_DEBUG */

#ifdef TCL_THREADS
/* declared in tclObj.c */
extern Tcl_Mutex tclObjMutex;
#endif

#  define TclNewObj(objPtr) \
    Tcl_MutexLock(&tclObjMutex); \
    if (tclFreeObjList == NULL) { \
	TclAllocateFreeObjects(); \
    } \
    (objPtr) = tclFreeObjList; \
    tclFreeObjList = (Tcl_Obj *) \
	tclFreeObjList->internalRep.otherValuePtr; \
    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL; \
    TclIncrObjsAllocated(); \
    Tcl_MutexUnlock(&tclObjMutex)

#  define TclDecrRefCount(objPtr) \
    if (--(objPtr)->refCount <= 0) { \
	if (((objPtr)->typePtr != NULL) \
		&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
	    (objPtr)->typePtr->freeIntRepProc(objPtr); \
	} \
	if (((objPtr)->bytes != NULL) \
		&& ((objPtr)->bytes != tclEmptyStringRep)) { \
	    ckfree((char *) (objPtr)->bytes); \
	} \
	Tcl_MutexLock(&tclObjMutex); \
	(objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
	tclFreeObjList = (objPtr); \
	TclIncrObjsFreed(); \
	Tcl_MutexUnlock(&tclObjMutex); \
    }
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to set a Tcl_Obj's string representation
 * to a copy of the "len" bytes starting at "bytePtr". This code
 * works even if the byte array contains NULLs as long as the length







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>















>
>
>
>













<
|
|
<
<
<
<
<
|
<
<
<



|
<
|
|

<
<
<








|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
|
<
<
<
<
<

|
<
<
<
<
<
<
<
|
<
<
<
<











|
|
<
<
<
<

|
<
<
<
<
<
<
<
<
<
|
<








|
|
|
|
|
|
|
|
<
<
<
<
<
|

|
<
<
<
<
<
<
<
<
<
|
|
|
<
|
|







2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127

2128
2129





2130



2131
2132
2133
2134

2135
2136
2137



2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180





2181
2182







2183




2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196




2197
2198









2199

2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215





2216
2217
2218









2219
2220
2221

2222
2223
2224
2225
2226
2227
2228
2229
2230
EXTERN int	TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int	TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int	TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Parse *parsePtr, struct CompileEnv *envPtr));

/*
 * Functions defined in generic/tclVar.c and currenttly exported only 
 * for use by the bytecode compiler and engine. Some of these could later 
 * be placed in the public interface.
 */

EXTERN Var *	TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp,
		    CONST char *arrayName, CONST char *elName, CONST int flags,
		    CONST char *msg, CONST int createPart1,
		    CONST int createPart2, Var *arrayPtr));	
EXTERN Var *    TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *part1Ptr, CONST char *part2, int flags,
		    CONST char *msg, CONST int createPart1,
		    CONST int createPart2, Var **arrayPtrPtr));
EXTERN Tcl_Obj *TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
		    Var *arrayPtr, CONST char *part1, CONST char *part2,
		    CONST int flags));
EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
		    Var *arrayPtr, CONST char *part1, CONST char *part2,
		    Tcl_Obj *newValuePtr, CONST int flags));
EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
		    Var *arrayPtr, CONST char *part1, CONST char *part2,
		    CONST long i, CONST int flags));

/*
 *----------------------------------------------------------------
 * Macros used by the Tcl core to create and release Tcl objects.
 * TclNewObj(objPtr) creates a new object denoting an empty string.
 * TclDecrRefCount(objPtr) decrements the object's reference count,
 * and frees the object if its reference count is zero.
 * These macros are inline versions of Tcl_NewObj() and
 * Tcl_DecrRefCount(). Notice that the names differ in not having
 * a "_" after the "Tcl". Notice also that these macros reference
 * their argument more than once, so you should avoid calling them
 * with an expression that is expensive to compute or has
 * side effects. The ANSI C "prototypes" for these macros are:
 *
 * EXTERN void	TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
 * EXTERN void	TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
 *
 * These macros are defined in terms of two macros that depend on 
 * memory allocator in use: TclAllocObjStorage, TclFreeObjStorage.
 * They are defined below.
 *----------------------------------------------------------------
 */

#ifdef TCL_COMPILE_STATS
#  define TclIncrObjsAllocated() \
    tclObjsAlloced++
#  define TclIncrObjsFreed() \
    tclObjsFreed++
#else
#  define TclIncrObjsAllocated()
#  define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */


#define TclNewObj(objPtr) \
    TclAllocObjStorage(objPtr); \





    TclIncrObjsAllocated(); \



    (objPtr)->refCount = 0; \
    (objPtr)->bytes    = tclEmptyStringRep; \
    (objPtr)->length   = 0; \
    (objPtr)->typePtr  = NULL


#define TclDecrRefCount(objPtr) \
    if (--(objPtr)->refCount <= 0) { \



	if (((objPtr)->typePtr != NULL) \
		&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
	    (objPtr)->typePtr->freeIntRepProc(objPtr); \
	} \
	if (((objPtr)->bytes != NULL) \
		&& ((objPtr)->bytes != tclEmptyStringRep)) { \
	    ckfree((char *) (objPtr)->bytes); \
	} \
        TclFreeObjStorage(objPtr); \
	TclIncrObjsFreed(); \
    }

#ifdef TCL_MEM_DEBUG
#  define TclAllocObjStorage(objPtr) \
       (objPtr) = (Tcl_Obj *) \
           Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__)

#  define TclFreeObjStorage(objPtr) \
       if ((objPtr)->refCount < -1) { \
           panic("Reference count for %lx was negative: %s line %d", \
	           (objPtr), __FILE__, __LINE__); \
       } \
       ckfree((char *) (objPtr))
     
#  define TclDbNewObj(objPtr, file, line) \
       (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
       (objPtr)->refCount = 0; \
       (objPtr)->bytes    = tclEmptyStringRep; \
       (objPtr)->length   = 0; \
       (objPtr)->typePtr  = NULL; \
       TclIncrObjsAllocated()
     
#elif defined(PURIFY)

/*
 * The PURIFY mode is like the regular mode, but instead of doing block
 * Tcl_Obj allocation and keeping a freed list for efficiency, it always
 * allocates and frees a single Tcl_Obj so that tools like Purify can
 * better track memory leaks
 */

#  define TclAllocObjStorage(objPtr) \
       (objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj))






#  define TclFreeObjStorage(objPtr) \







       ckfree((char *) (objPtr))





#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)

/*
 * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
 * from per-thread caches.
 */

EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void));
EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));

#  define TclAllocObjStorage(objPtr) \
       (objPtr) = TclThreadAllocObj()





#  define TclFreeObjStorage(objPtr) \









       TclThreadFreeObj((objPtr))


#else /* not TCL_MEM_DEBUG */

#ifdef TCL_THREADS
/* declared in tclObj.c */
extern Tcl_Mutex tclObjMutex;
#endif

#  define TclAllocObjStorage(objPtr) \
       Tcl_MutexLock(&tclObjMutex); \
       if (tclFreeObjList == NULL) { \
	   TclAllocateFreeObjects(); \
       } \
       (objPtr) = tclFreeObjList; \
       tclFreeObjList = (Tcl_Obj *) \
	   tclFreeObjList->internalRep.otherValuePtr; \





       Tcl_MutexUnlock(&tclObjMutex)

#  define TclFreeObjStorage(objPtr) \









       Tcl_MutexLock(&tclObjMutex); \
       (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
       tclFreeObjList = (objPtr); \

       Tcl_MutexUnlock(&tclObjMutex)

#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------
 * Macro used by the Tcl core to set a Tcl_Obj's string representation
 * to a copy of the "len" bytes starting at "bytePtr". This code
 * works even if the byte array contains NULLs as long as the length
Changes to generic/tclIntDecls.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclIntDecls.h --
 *
 *	This file contains the declarations for all unsupported
 *	functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIntDecls.h,v 1.29.2.4 2002/06/10 05:33:12 wolfsuit Exp $
 */

#ifndef _TCLINTDECLS
#define _TCLINTDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclIntDecls.h --
 *
 *	This file contains the declarations for all unsupported
 *	functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIntDecls.h,v 1.29.2.5 2002/08/20 20:25:26 das Exp $
 */

#ifndef _TCLINTDECLS
#define _TCLINTDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
				TclAccessProc_ * proc));
/* 2 */
EXTERN int		TclAccessInsertProc _ANSI_ARGS_((
				TclAccessProc_ * proc));
/* 3 */
EXTERN void		TclAllocateFreeObjects _ANSI_ARGS_((void));
/* Slot 4 is reserved */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 5 */
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, 
				int numPids, Tcl_Pid * pidPtr, 
				Tcl_Channel errorChan));
#endif /* UNIX */
#ifdef __WIN32__
/* 5 */
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, 
				int numPids, Tcl_Pid * pidPtr, 
				Tcl_Channel errorChan));
#endif /* __WIN32__ */
/* 6 */
EXTERN void		TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr));
/* 7 */
EXTERN int		TclCopyAndCollapse _ANSI_ARGS_((int count, 
				CONST char * src, char * dst));
/* 8 */
EXTERN int		TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel inChan, Tcl_Channel outChan, 
				int toRead, Tcl_Obj * cmdPtr));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 9 */
EXTERN int		TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp, 
				int argc, CONST char ** argv, 
				Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, 
				TclFile * outPipePtr, TclFile * errFilePtr));
#endif /* UNIX */
#ifdef __WIN32__







|




















|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
				TclAccessProc_ * proc));
/* 2 */
EXTERN int		TclAccessInsertProc _ANSI_ARGS_((
				TclAccessProc_ * proc));
/* 3 */
EXTERN void		TclAllocateFreeObjects _ANSI_ARGS_((void));
/* Slot 4 is reserved */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 5 */
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, 
				int numPids, Tcl_Pid * pidPtr, 
				Tcl_Channel errorChan));
#endif /* UNIX */
#ifdef __WIN32__
/* 5 */
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, 
				int numPids, Tcl_Pid * pidPtr, 
				Tcl_Channel errorChan));
#endif /* __WIN32__ */
/* 6 */
EXTERN void		TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr));
/* 7 */
EXTERN int		TclCopyAndCollapse _ANSI_ARGS_((int count, 
				CONST char * src, char * dst));
/* 8 */
EXTERN int		TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel inChan, Tcl_Channel outChan, 
				int toRead, Tcl_Obj * cmdPtr));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 9 */
EXTERN int		TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp, 
				int argc, CONST char ** argv, 
				Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, 
				TclFile * outPipePtr, TclFile * errFilePtr));
#endif /* UNIX */
#ifdef __WIN32__
115
116
117
118
119
120
121
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
EXTERN void		TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr));
/* Slot 26 is reserved */
/* 27 */
EXTERN int		TclGetDate _ANSI_ARGS_((char * p, unsigned long now, 
				long zone, unsigned long * timePtr));
/* 28 */
EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
/* 29 */
EXTERN Tcl_Obj *	TclGetElementOfIndexedArray _ANSI_ARGS_((
				Tcl_Interp * interp, int localIndex, 
				Tcl_Obj * elemPtr, int flags));
/* Slot 30 is reserved */
/* 31 */
EXTERN char *		TclGetExtension _ANSI_ARGS_((char * name));
/* 32 */
EXTERN int		TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, CallFrame ** framePtrPtr));
/* 33 */
EXTERN TclCmdProcType	TclGetInterpProc _ANSI_ARGS_((void));
/* 34 */
EXTERN int		TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int endValue, 
				int * indexPtr));
/* 35 */
EXTERN Tcl_Obj *	TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, 
				int localIndex, int flags));
/* 36 */
EXTERN int		TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, long * longPtr));
/* 37 */
EXTERN int		TclGetLoadedPackages _ANSI_ARGS_((
				Tcl_Interp * interp, char * targetName));
/* 38 */







|
<
<
<












|
<
<







115
116
117
118
119
120
121
122



123
124
125
126
127
128
129
130
131
132
133
134
135


136
137
138
139
140
141
142
EXTERN void		TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr));
/* Slot 26 is reserved */
/* 27 */
EXTERN int		TclGetDate _ANSI_ARGS_((char * p, unsigned long now, 
				long zone, unsigned long * timePtr));
/* 28 */
EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
/* Slot 29 is reserved */



/* Slot 30 is reserved */
/* 31 */
EXTERN char *		TclGetExtension _ANSI_ARGS_((char * name));
/* 32 */
EXTERN int		TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, CallFrame ** framePtrPtr));
/* 33 */
EXTERN TclCmdProcType	TclGetInterpProc _ANSI_ARGS_((void));
/* 34 */
EXTERN int		TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * objPtr, int endValue, 
				int * indexPtr));
/* Slot 35 is reserved */


/* 36 */
EXTERN int		TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * str, long * longPtr));
/* 37 */
EXTERN int		TclGetLoadedPackages _ANSI_ARGS_((
				Tcl_Interp * interp, char * targetName));
/* 38 */
161
162
163
164
165
166
167
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
EXTERN Tcl_Command	TclGetOriginalCommand _ANSI_ARGS_((
				Tcl_Command command));
/* 42 */
EXTERN char *		TclpGetUserHome _ANSI_ARGS_((CONST char * name, 
				Tcl_DString * bufferPtr));
/* 43 */
EXTERN int		TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, 
				int argc, char ** argv, int flags));
/* 44 */
EXTERN int		TclGuessPackageName _ANSI_ARGS_((
				CONST char * fileName, Tcl_DString * bufPtr));
/* 45 */
EXTERN int		TclHideUnsafeCommands _ANSI_ARGS_((
				Tcl_Interp * interp));
/* 46 */
EXTERN int		TclInExit _ANSI_ARGS_((void));
/* 47 */
EXTERN Tcl_Obj *	TclIncrElementOfIndexedArray _ANSI_ARGS_((
				Tcl_Interp * interp, int localIndex, 
				Tcl_Obj * elemPtr, long incrAmount));
/* 48 */
EXTERN Tcl_Obj *	TclIncrIndexedScalar _ANSI_ARGS_((
				Tcl_Interp * interp, int localIndex, 
				long incrAmount));
/* 49 */
EXTERN Tcl_Obj *	TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				long incrAmount, int part1NotParsed));
/* 50 */
EXTERN void		TclInitCompiledLocals _ANSI_ARGS_((
				Tcl_Interp * interp, CallFrame * framePtr, 
				Namespace * nsPtr));
/* 51 */
EXTERN int		TclInterpInit _ANSI_ARGS_((Tcl_Interp * interp));
/* 52 */
EXTERN int		TclInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc, 
				char ** argv, int flags));
/* 53 */
EXTERN int		TclInvokeObjectCommand _ANSI_ARGS_((
				ClientData clientData, Tcl_Interp * interp, 
				int argc, char ** argv));
/* 54 */
EXTERN int		TclInvokeStringCommand _ANSI_ARGS_((
				ClientData clientData, Tcl_Interp * interp, 
				int objc, Tcl_Obj *CONST objv[]));
/* 55 */
EXTERN Proc *		TclIsProc _ANSI_ARGS_((Command * cmdPtr));
/* Slot 56 is reserved */
/* Slot 57 is reserved */
/* 58 */
EXTERN Var *		TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, 
				char * part1, CONST char * part2, int flags, 
				char * msg, int createPart1, int createPart2, 
				Var ** arrayPtrPtr));
/* Slot 59 is reserved */
/* 60 */
EXTERN int		TclNeedSpace _ANSI_ARGS_((CONST char * start, 
				CONST char * end));
/* 61 */
EXTERN Tcl_Obj *	TclNewProcBodyObj _ANSI_ARGS_((Proc * procPtr));
/* 62 */







|








|
<
<
<
|
<
<
<












|



|










|
|
|







156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172



173



174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
EXTERN Tcl_Command	TclGetOriginalCommand _ANSI_ARGS_((
				Tcl_Command command));
/* 42 */
EXTERN char *		TclpGetUserHome _ANSI_ARGS_((CONST char * name, 
				Tcl_DString * bufferPtr));
/* 43 */
EXTERN int		TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, 
				int argc, CONST84 char ** argv, int flags));
/* 44 */
EXTERN int		TclGuessPackageName _ANSI_ARGS_((
				CONST char * fileName, Tcl_DString * bufPtr));
/* 45 */
EXTERN int		TclHideUnsafeCommands _ANSI_ARGS_((
				Tcl_Interp * interp));
/* 46 */
EXTERN int		TclInExit _ANSI_ARGS_((void));
/* Slot 47 is reserved */



/* Slot 48 is reserved */



/* 49 */
EXTERN Tcl_Obj *	TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, 
				long incrAmount, int part1NotParsed));
/* 50 */
EXTERN void		TclInitCompiledLocals _ANSI_ARGS_((
				Tcl_Interp * interp, CallFrame * framePtr, 
				Namespace * nsPtr));
/* 51 */
EXTERN int		TclInterpInit _ANSI_ARGS_((Tcl_Interp * interp));
/* 52 */
EXTERN int		TclInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc, 
				CONST84 char ** argv, int flags));
/* 53 */
EXTERN int		TclInvokeObjectCommand _ANSI_ARGS_((
				ClientData clientData, Tcl_Interp * interp, 
				int argc, CONST84 char ** argv));
/* 54 */
EXTERN int		TclInvokeStringCommand _ANSI_ARGS_((
				ClientData clientData, Tcl_Interp * interp, 
				int objc, Tcl_Obj *CONST objv[]));
/* 55 */
EXTERN Proc *		TclIsProc _ANSI_ARGS_((Command * cmdPtr));
/* Slot 56 is reserved */
/* Slot 57 is reserved */
/* 58 */
EXTERN Var *		TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * part1, CONST char * part2, 
				int flags, CONST char * msg, int createPart1, 
				int createPart2, Var ** arrayPtrPtr));
/* Slot 59 is reserved */
/* 60 */
EXTERN int		TclNeedSpace _ANSI_ARGS_((CONST char * start, 
				CONST char * end));
/* 61 */
EXTERN Tcl_Obj *	TclNewProcBodyObj _ANSI_ARGS_((Proc * procPtr));
/* 62 */
262
263
264
265
266
267
268
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
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
EXTERN char *		TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, 
				Tcl_Interp * interp, char * name1, 
				CONST char * name2, int flags));
/* 89 */
EXTERN int		TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Interp * cmdInterp, Tcl_Command cmd));
/* Slot 90 is reserved */
/* 91 */
EXTERN void		TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr));
/* 92 */
EXTERN int		TclProcCompileProc _ANSI_ARGS_((Tcl_Interp * interp, 
				Proc * procPtr, Tcl_Obj * bodyPtr, 
				Namespace * nsPtr, CONST char * description, 
				CONST char * procName));
/* 93 */
EXTERN void		TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
/* 94 */
EXTERN int		TclProcInterpProc _ANSI_ARGS_((ClientData clientData, 
				Tcl_Interp * interp, int argc, char ** argv));

/* Slot 95 is reserved */
/* 96 */
EXTERN int		TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				char * oldName, char * newName));
/* 97 */
EXTERN void		TclResetShadowedCmdRefs _ANSI_ARGS_((
				Tcl_Interp * interp, Command * newCmdPtr));
/* 98 */
EXTERN int		TclServiceIdle _ANSI_ARGS_((void));
/* 99 */
EXTERN Tcl_Obj *	TclSetElementOfIndexedArray _ANSI_ARGS_((
				Tcl_Interp * interp, int localIndex, 
				Tcl_Obj * elemPtr, Tcl_Obj * objPtr, 
				int flags));
/* 100 */
EXTERN Tcl_Obj *	TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, 
				int localIndex, Tcl_Obj * objPtr, int flags));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 101 */
EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char * string));
#endif /* UNIX */
#ifdef __WIN32__
/* 101 */
EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char * string));
#endif /* __WIN32__ */
/* 102 */
EXTERN void		TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp));
/* 103 */
EXTERN int		TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp, 
				char * str, char * proto, int * portPtr));
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 104 */
EXTERN int		TclSockMinimumBuffers _ANSI_ARGS_((int sock, 
				int size));
#endif /* UNIX */
#ifdef __WIN32__
/* 104 */
EXTERN int		TclSockMinimumBuffers _ANSI_ARGS_((int sock, 







|
















|
>









|
<
<
<
<
|
<
<
|












|







251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286




287


288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
EXTERN char *		TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, 
				Tcl_Interp * interp, CONST char * name1, 
				CONST char * name2, int flags));
/* 89 */
EXTERN int		TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Interp * cmdInterp, Tcl_Command cmd));
/* Slot 90 is reserved */
/* 91 */
EXTERN void		TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr));
/* 92 */
EXTERN int		TclProcCompileProc _ANSI_ARGS_((Tcl_Interp * interp, 
				Proc * procPtr, Tcl_Obj * bodyPtr, 
				Namespace * nsPtr, CONST char * description, 
				CONST char * procName));
/* 93 */
EXTERN void		TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
/* 94 */
EXTERN int		TclProcInterpProc _ANSI_ARGS_((ClientData clientData, 
				Tcl_Interp * interp, int argc, 
				CONST84 char ** argv));
/* Slot 95 is reserved */
/* 96 */
EXTERN int		TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, 
				char * oldName, char * newName));
/* 97 */
EXTERN void		TclResetShadowedCmdRefs _ANSI_ARGS_((
				Tcl_Interp * interp, Command * newCmdPtr));
/* 98 */
EXTERN int		TclServiceIdle _ANSI_ARGS_((void));
/* Slot 99 is reserved */




/* Slot 100 is reserved */


#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 101 */
EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char * string));
#endif /* UNIX */
#ifdef __WIN32__
/* 101 */
EXTERN char *		TclSetPreInitScript _ANSI_ARGS_((char * string));
#endif /* __WIN32__ */
/* 102 */
EXTERN void		TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp));
/* 103 */
EXTERN int		TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp, 
				char * str, char * proto, int * portPtr));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 104 */
EXTERN int		TclSockMinimumBuffers _ANSI_ARGS_((int sock, 
				int size));
#endif /* UNIX */
#ifdef __WIN32__
/* 104 */
EXTERN int		TclSockMinimumBuffers _ANSI_ARGS_((int sock, 
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
				Tcl_ResolverInfo * resInfo));
/* 119 */
EXTERN int		Tcl_GetNamespaceResolvers _ANSI_ARGS_((
				Tcl_Namespace * namespacePtr, 
				Tcl_ResolverInfo * resInfo));
/* 120 */
EXTERN Tcl_Var		Tcl_FindNamespaceVar _ANSI_ARGS_((
				Tcl_Interp * interp, char * name, 
				Tcl_Namespace * contextNsPtr, int flags));
/* 121 */
EXTERN int		Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Namespace * nsPtr, CONST char * pattern));
/* 122 */
EXTERN Tcl_Command	Tcl_GetCommandFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));







|







353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
				Tcl_ResolverInfo * resInfo));
/* 119 */
EXTERN int		Tcl_GetNamespaceResolvers _ANSI_ARGS_((
				Tcl_Namespace * namespacePtr, 
				Tcl_ResolverInfo * resInfo));
/* 120 */
EXTERN Tcl_Var		Tcl_FindNamespaceVar _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * name, 
				Tcl_Namespace * contextNsPtr, int flags));
/* 121 */
EXTERN int		Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Namespace * nsPtr, CONST char * pattern));
/* 122 */
EXTERN Tcl_Command	Tcl_GetCommandFromObj _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr));
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
				CONST char * format, CONST struct tm * t, 
				int useGMT));
/* 135 */
EXTERN int		TclpCheckStackSpace _ANSI_ARGS_((void));
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
EXTERN CONST char *	TclGetEnv _ANSI_ARGS_((CONST char * name, 
				Tcl_DString * valuePtr));
/* Slot 139 is reserved */
/* 140 */
EXTERN int		TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes, 
				int length));
/* 141 */
EXTERN CONST char *	TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
/* 142 */
EXTERN int		TclSetByteCodeFromAny _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				CompileHookProc * hookProc, 
				ClientData clientData));
/* 143 */







|






|







407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
				CONST char * format, CONST struct tm * t, 
				int useGMT));
/* 135 */
EXTERN int		TclpCheckStackSpace _ANSI_ARGS_((void));
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, 
				Tcl_DString * valuePtr));
/* Slot 139 is reserved */
/* 140 */
EXTERN int		TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes, 
				int length));
/* 141 */
EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_DString * cwdPtr));
/* 142 */
EXTERN int		TclSetByteCodeFromAny _ANSI_ARGS_((
				Tcl_Interp * interp, Tcl_Obj * objPtr, 
				CompileHookProc * hookProc, 
				ClientData clientData));
/* 143 */
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
/* Slot 154 is reserved */
/* Slot 155 is reserved */
/* 156 */
EXTERN void		TclRegError _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * msg, int status));
/* 157 */
EXTERN Var *		TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp, 
				char * varName));
/* 158 */
EXTERN void		TclSetStartupScriptFileName _ANSI_ARGS_((
				CONST char * filename));
/* 159 */
EXTERN CONST char *	TclGetStartupScriptFileName _ANSI_ARGS_((void));
/* Slot 160 is reserved */
/* 161 */
EXTERN int		TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel chan, Tcl_Obj * cmdObjPtr));
/* 162 */
EXTERN void		TclChannelEventScriptInvoker _ANSI_ARGS_((
				ClientData clientData, int flags));







|




|







455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
/* Slot 154 is reserved */
/* Slot 155 is reserved */
/* 156 */
EXTERN void		TclRegError _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * msg, int status));
/* 157 */
EXTERN Var *		TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp, 
				CONST char * varName));
/* 158 */
EXTERN void		TclSetStartupScriptFileName _ANSI_ARGS_((
				CONST char * filename));
/* 159 */
EXTERN CONST84_RETURN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
/* Slot 160 is reserved */
/* 161 */
EXTERN int		TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel chan, Tcl_Obj * cmdObjPtr));
/* 162 */
EXTERN void		TclChannelEventScriptInvoker _ANSI_ARGS_((
				ClientData clientData, int flags));
502
503
504
505
506
507
508












509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
EXTERN void		TclSetStartupScriptPath _ANSI_ARGS_((
				Tcl_Obj * pathPtr));
/* 168 */
EXTERN Tcl_Obj *	TclGetStartupScriptPath _ANSI_ARGS_((void));
/* 169 */
EXTERN int		TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1, 
				CONST char * s2, unsigned long n));













typedef struct TclIntStubs {
    int magic;
    struct TclIntStubHooks *hooks;

    void *reserved0;
    int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
    int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
    void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
    void *reserved4;
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
#endif /* UNIX */
#ifdef __WIN32__
    int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved5;
#endif /* MAC_TCL */
    void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */
    int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */
    int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved9;







>
>
>
>
>
>
>
>
>
>
>
>










|











|







486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
EXTERN void		TclSetStartupScriptPath _ANSI_ARGS_((
				Tcl_Obj * pathPtr));
/* 168 */
EXTERN Tcl_Obj *	TclGetStartupScriptPath _ANSI_ARGS_((void));
/* 169 */
EXTERN int		TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1, 
				CONST char * s2, unsigned long n));
/* 170 */
EXTERN int		TclCheckInterpTraces _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * command, 
				int numChars, Command * cmdPtr, int result, 
				int traceFlags, int objc, 
				Tcl_Obj *CONST objv[]));
/* 171 */
EXTERN int		TclCheckExecutionTraces _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * command, 
				int numChars, Command * cmdPtr, int result, 
				int traceFlags, int objc, 
				Tcl_Obj *CONST objv[]));

typedef struct TclIntStubs {
    int magic;
    struct TclIntStubHooks *hooks;

    void *reserved0;
    int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
    int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
    void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
    void *reserved4;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
#endif /* UNIX */
#ifdef __WIN32__
    int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved5;
#endif /* MAC_TCL */
    void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */
    int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */
    int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved9;
552
553
554
555
556
557
558
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
    int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
    Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
    int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
    void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
    void *reserved26;
    int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
    Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
    Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int flags)); /* 29 */
    void *reserved30;
    char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
    int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
    TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
    int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
    Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int flags)); /* 35 */
    int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */
    int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
    int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
    TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
    int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * seekFlagPtr)); /* 40 */
    Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
    char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
    int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 43 */
    int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
    int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
    int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
    Tcl_Obj * (*tclIncrElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, long incrAmount)); /* 47 */
    Tcl_Obj * (*tclIncrIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, long incrAmount)); /* 48 */
    Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
    void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
    int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
    int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 52 */
    int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 53 */
    int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
    Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
    void *reserved56;
    void *reserved57;
    Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, CONST char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
    void *reserved59;
    int (*tclNeedSpace) _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 60 */
    Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
    int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
    int (*tclObjInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 63 */
    int (*tclObjInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 64 */
    int (*tclObjInvokeGlobal) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 65 */







|





|







|



|
|



|
|




|







548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
    int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
    Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
    int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
    void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
    void *reserved26;
    int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
    Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
    void *reserved29;
    void *reserved30;
    char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
    int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
    TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
    int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
    void *reserved35;
    int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */
    int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
    int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
    TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
    int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * seekFlagPtr)); /* 40 */
    Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
    char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
    int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 43 */
    int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
    int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
    int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
    void *reserved47;
    void *reserved48;
    Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
    void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
    int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
    int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 52 */
    int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */
    int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
    Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
    void *reserved56;
    void *reserved57;
    Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, CONST char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
    void *reserved59;
    int (*tclNeedSpace) _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 60 */
    Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
    int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
    int (*tclObjInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 63 */
    int (*tclObjInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 64 */
    int (*tclObjInvokeGlobal) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 65 */
611
612
613
614
615
616
617
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
    char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
    void *reserved82;
    void *reserved83;
    void *reserved84;
    void *reserved85;
    void *reserved86;
    void *reserved87;
    char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, CONST char * name2, int flags)); /* 88 */
    int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */
    void *reserved90;
    void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */
    int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */
    void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
    int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 94 */
    void *reserved95;
    int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
    void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
    int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
    Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int flags)); /* 99 */
    Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int flags)); /* 100 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* UNIX */
#ifdef __WIN32__
    char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved101;
#endif /* MAC_TCL */
    void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */
    int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
#endif /* UNIX */
#ifdef __WIN32__
    int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved104;







|





|




|
|
|










|







607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
    char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
    void *reserved82;
    void *reserved83;
    void *reserved84;
    void *reserved85;
    void *reserved86;
    void *reserved87;
    char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flags)); /* 88 */
    int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */
    void *reserved90;
    void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */
    int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */
    void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
    int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 94 */
    void *reserved95;
    int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
    void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
    int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
    void *reserved99;
    void *reserved100;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* UNIX */
#ifdef __WIN32__
    char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved101;
#endif /* MAC_TCL */
    void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */
    int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
#endif /* UNIX */
#ifdef __WIN32__
    int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    void *reserved104;
659
660
661
662
663
664
665
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
    Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
    void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
    int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */
    Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
    Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
    int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
    int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
    Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */
    int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 121 */
    Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 122 */
    void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 123 */
    Tcl_Namespace * (*tcl_GetCurrentNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 124 */
    Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */
    void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */
    int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */
    void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */
    int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */
    int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */
    void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */
    int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
    struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */
    size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t, int useGMT)); /* 134 */
    int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
    void *reserved136;
    void *reserved137;
    CONST char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
    void *reserved139;
    int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
    CONST char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
    int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
    int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
    void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
    struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */
    TclHandle (*tclHandleCreate) _ANSI_ARGS_((VOID * ptr)); /* 146 */
    void (*tclHandleFree) _ANSI_ARGS_((TclHandle handle)); /* 147 */
    TclHandle (*tclHandlePreserve) _ANSI_ARGS_((TclHandle handle)); /* 148 */
    void (*tclHandleRelease) _ANSI_ARGS_((TclHandle handle)); /* 149 */
    int (*tclRegAbout) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp re)); /* 150 */
    void (*tclRegExpRangeUniChar) _ANSI_ARGS_((Tcl_RegExp re, int index, int * startPtr, int * endPtr)); /* 151 */
    void (*tclSetLibraryPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 152 */
    Tcl_Obj * (*tclGetLibraryPath) _ANSI_ARGS_((void)); /* 153 */
    void *reserved154;
    void *reserved155;
    void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 156 */
    Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */
    void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */
    CONST char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
    void *reserved160;
    int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
    void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
    void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */
    void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
    void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
    int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */
    void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
    Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
    int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */


} TclIntStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus







|

















|


|















|

|










>
>







655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
    Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
    void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
    int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */
    Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
    Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
    int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
    int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
    Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */
    int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 121 */
    Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 122 */
    void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 123 */
    Tcl_Namespace * (*tcl_GetCurrentNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 124 */
    Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */
    void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */
    int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */
    void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */
    int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */
    int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */
    void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */
    int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
    struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */
    size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t, int useGMT)); /* 134 */
    int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
    void *reserved136;
    void *reserved137;
    CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
    void *reserved139;
    int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
    CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
    int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
    int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
    void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
    struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */
    TclHandle (*tclHandleCreate) _ANSI_ARGS_((VOID * ptr)); /* 146 */
    void (*tclHandleFree) _ANSI_ARGS_((TclHandle handle)); /* 147 */
    TclHandle (*tclHandlePreserve) _ANSI_ARGS_((TclHandle handle)); /* 148 */
    void (*tclHandleRelease) _ANSI_ARGS_((TclHandle handle)); /* 149 */
    int (*tclRegAbout) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp re)); /* 150 */
    void (*tclRegExpRangeUniChar) _ANSI_ARGS_((Tcl_RegExp re, int index, int * startPtr, int * endPtr)); /* 151 */
    void (*tclSetLibraryPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 152 */
    Tcl_Obj * (*tclGetLibraryPath) _ANSI_ARGS_((void)); /* 153 */
    void *reserved154;
    void *reserved155;
    void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 156 */
    Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 157 */
    void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */
    CONST84_RETURN char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
    void *reserved160;
    int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
    void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
    void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */
    void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
    void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
    int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */
    void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
    Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
    int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
    int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
    int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
} TclIntStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
	(tclIntStubsPtr->tclAccessInsertProc) /* 2 */
#endif
#ifndef TclAllocateFreeObjects
#define TclAllocateFreeObjects \
	(tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
#endif
/* Slot 4 is reserved */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef TclCleanupChildren
#define TclCleanupChildren \
	(tclIntStubsPtr->tclCleanupChildren) /* 5 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclCleanupChildren







|







737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
	(tclIntStubsPtr->tclAccessInsertProc) /* 2 */
#endif
#ifndef TclAllocateFreeObjects
#define TclAllocateFreeObjects \
	(tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
#endif
/* Slot 4 is reserved */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclCleanupChildren
#define TclCleanupChildren \
	(tclIntStubsPtr->tclCleanupChildren) /* 5 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclCleanupChildren
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
#define TclCopyAndCollapse \
	(tclIntStubsPtr->tclCopyAndCollapse) /* 7 */
#endif
#ifndef TclCopyChannel
#define TclCopyChannel \
	(tclIntStubsPtr->tclCopyChannel) /* 8 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef TclCreatePipeline
#define TclCreatePipeline \
	(tclIntStubsPtr->tclCreatePipeline) /* 9 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclCreatePipeline







|







761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
#define TclCopyAndCollapse \
	(tclIntStubsPtr->tclCopyAndCollapse) /* 7 */
#endif
#ifndef TclCopyChannel
#define TclCopyChannel \
	(tclIntStubsPtr->tclCopyChannel) /* 8 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclCreatePipeline
#define TclCreatePipeline \
	(tclIntStubsPtr->tclCreatePipeline) /* 9 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclCreatePipeline
830
831
832
833
834
835
836
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
#define TclGetDate \
	(tclIntStubsPtr->tclGetDate) /* 27 */
#endif
#ifndef TclpGetDefaultStdChannel
#define TclpGetDefaultStdChannel \
	(tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
#endif
#ifndef TclGetElementOfIndexedArray
#define TclGetElementOfIndexedArray \
	(tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */
#endif
/* Slot 30 is reserved */
#ifndef TclGetExtension
#define TclGetExtension \
	(tclIntStubsPtr->tclGetExtension) /* 31 */
#endif
#ifndef TclGetFrame
#define TclGetFrame \
	(tclIntStubsPtr->tclGetFrame) /* 32 */
#endif
#ifndef TclGetInterpProc
#define TclGetInterpProc \
	(tclIntStubsPtr->tclGetInterpProc) /* 33 */
#endif
#ifndef TclGetIntForIndex
#define TclGetIntForIndex \
	(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
#endif
#ifndef TclGetIndexedScalar
#define TclGetIndexedScalar \
	(tclIntStubsPtr->tclGetIndexedScalar) /* 35 */
#endif
#ifndef TclGetLong
#define TclGetLong \
	(tclIntStubsPtr->tclGetLong) /* 36 */
#endif
#ifndef TclGetLoadedPackages
#define TclGetLoadedPackages \
	(tclIntStubsPtr->tclGetLoadedPackages) /* 37 */







|
<
<
<

















|
<
<
<







828
829
830
831
832
833
834
835



836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853



854
855
856
857
858
859
860
#define TclGetDate \
	(tclIntStubsPtr->tclGetDate) /* 27 */
#endif
#ifndef TclpGetDefaultStdChannel
#define TclpGetDefaultStdChannel \
	(tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
#endif
/* Slot 29 is reserved */



/* Slot 30 is reserved */
#ifndef TclGetExtension
#define TclGetExtension \
	(tclIntStubsPtr->tclGetExtension) /* 31 */
#endif
#ifndef TclGetFrame
#define TclGetFrame \
	(tclIntStubsPtr->tclGetFrame) /* 32 */
#endif
#ifndef TclGetInterpProc
#define TclGetInterpProc \
	(tclIntStubsPtr->tclGetInterpProc) /* 33 */
#endif
#ifndef TclGetIntForIndex
#define TclGetIntForIndex \
	(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
#endif
/* Slot 35 is reserved */



#ifndef TclGetLong
#define TclGetLong \
	(tclIntStubsPtr->tclGetLong) /* 36 */
#endif
#ifndef TclGetLoadedPackages
#define TclGetLoadedPackages \
	(tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
#define TclHideUnsafeCommands \
	(tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
#endif
#ifndef TclInExit
#define TclInExit \
	(tclIntStubsPtr->tclInExit) /* 46 */
#endif
#ifndef TclIncrElementOfIndexedArray
#define TclIncrElementOfIndexedArray \
	(tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */
#endif
#ifndef TclIncrIndexedScalar
#define TclIncrIndexedScalar \
	(tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */
#endif
#ifndef TclIncrVar2
#define TclIncrVar2 \
	(tclIntStubsPtr->tclIncrVar2) /* 49 */
#endif
#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
	(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */







|
|
<
<
<
<
<
<







891
892
893
894
895
896
897
898
899






900
901
902
903
904
905
906
#define TclHideUnsafeCommands \
	(tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
#endif
#ifndef TclInExit
#define TclInExit \
	(tclIntStubsPtr->tclInExit) /* 46 */
#endif
/* Slot 47 is reserved */
/* Slot 48 is reserved */






#ifndef TclIncrVar2
#define TclIncrVar2 \
	(tclIntStubsPtr->tclIncrVar2) /* 49 */
#endif
#ifndef TclInitCompiledLocals
#define TclInitCompiledLocals \
	(tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
1053
1054
1055
1056
1057
1058
1059
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
#define TclResetShadowedCmdRefs \
	(tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */
#endif
#ifndef TclServiceIdle
#define TclServiceIdle \
	(tclIntStubsPtr->tclServiceIdle) /* 98 */
#endif
#ifndef TclSetElementOfIndexedArray
#define TclSetElementOfIndexedArray \
	(tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */
#endif
#ifndef TclSetIndexedScalar
#define TclSetIndexedScalar \
	(tclIntStubsPtr->tclSetIndexedScalar) /* 100 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
	(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
	(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
#endif
#endif /* __WIN32__ */
#ifndef TclSetupEnv
#define TclSetupEnv \
	(tclIntStubsPtr->tclSetupEnv) /* 102 */
#endif
#ifndef TclSockGetPort
#define TclSockGetPort \
	(tclIntStubsPtr->tclSockGetPort) /* 103 */
#endif
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef TclSockMinimumBuffers
#define TclSockMinimumBuffers \
	(tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclSockMinimumBuffers







|
<
<
<
<
<
|
<
|



















|







1039
1040
1041
1042
1043
1044
1045
1046





1047

1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
#define TclResetShadowedCmdRefs \
	(tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */
#endif
#ifndef TclServiceIdle
#define TclServiceIdle \
	(tclIntStubsPtr->tclServiceIdle) /* 98 */
#endif
/* Slot 99 is reserved */





/* Slot 100 is reserved */

#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
	(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
	(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
#endif
#endif /* __WIN32__ */
#ifndef TclSetupEnv
#define TclSetupEnv \
	(tclIntStubsPtr->tclSetupEnv) /* 102 */
#endif
#ifndef TclSockGetPort
#define TclSockGetPort \
	(tclIntStubsPtr->tclSockGetPort) /* 103 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclSockMinimumBuffers
#define TclSockMinimumBuffers \
	(tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclSockMinimumBuffers
1329
1330
1331
1332
1333
1334
1335








1336
1337
1338
1339
1340
1341
#define TclGetStartupScriptPath \
	(tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
#endif
#ifndef TclpUtfNcmp2
#define TclpUtfNcmp2 \
	(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
#endif









#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#endif /* _TCLINTDECLS */







>
>
>
>
>
>
>
>






1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
#define TclGetStartupScriptPath \
	(tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
#endif
#ifndef TclpUtfNcmp2
#define TclpUtfNcmp2 \
	(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
#endif
#ifndef TclCheckInterpTraces
#define TclCheckInterpTraces \
	(tclIntStubsPtr->tclCheckInterpTraces) /* 170 */
#endif
#ifndef TclCheckExecutionTraces
#define TclCheckExecutionTraces \
	(tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#endif /* _TCLINTDECLS */
Changes to generic/tclIntPlatDecls.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
/*
 * tclIntPlatDecls.h --
 *
 *	This file contains the declarations for all platform dependent
 *	unsupported functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.12.6.3 2002/06/10 05:33:12 wolfsuit Exp $
 */

#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl
 * script.  Any modifications to the function declarations below should be made
 * in the generic/tclInt.decls script.
 */

/* !BEGIN!: Do not edit below this line. */

/*
 * Exported function declarations:
 */

#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
/* 0 */
EXTERN void		TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel chan));
/* 1 */
EXTERN int		TclpCloseFile _ANSI_ARGS_((TclFile file));
/* 2 */
EXTERN Tcl_Channel	TclpCreateCommandChannel _ANSI_ARGS_((











|

















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
/*
 * tclIntPlatDecls.h --
 *
 *	This file contains the declarations for all platform dependent
 *	unsupported functions that are exported by the Tcl library.  These
 *	interfaces are not guaranteed to remain the same between
 *	versions.  Use at your own risk.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.12.6.4 2002/08/20 20:25:26 das Exp $
 */

#ifndef _TCLINTPLATDECLS
#define _TCLINTPLATDECLS

/*
 * WARNING: This file is automatically generated by the tools/genStubs.tcl
 * script.  Any modifications to the function declarations below should be made
 * in the generic/tclInt.decls script.
 */

/* !BEGIN!: Do not edit below this line. */

/*
 * Exported function declarations:
 */

#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 0 */
EXTERN void		TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp * interp, 
				Tcl_Channel chan));
/* 1 */
EXTERN int		TclpCloseFile _ANSI_ARGS_((TclFile file));
/* 2 */
EXTERN Tcl_Channel	TclpCreateCommandChannel _ANSI_ARGS_((
55
56
57
58
59
60
61








62
63
64
65
66
67
68
				int mode));
/* 8 */
EXTERN int		TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, 
				int timeout));
/* 9 */
EXTERN TclFile		TclpCreateTempFile _ANSI_ARGS_((
				CONST char * contents));








#endif /* UNIX */
#ifdef __WIN32__
/* 0 */
EXTERN void		TclWinConvertError _ANSI_ARGS_((DWORD errCode));
/* 1 */
EXTERN void		TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode));
/* 2 */







>
>
>
>
>
>
>
>







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
				int mode));
/* 8 */
EXTERN int		TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, 
				int timeout));
/* 9 */
EXTERN TclFile		TclpCreateTempFile _ANSI_ARGS_((
				CONST char * contents));
/* 10 */
EXTERN Tcl_DirEntry *	TclpReaddir _ANSI_ARGS_((DIR * dir));
/* 11 */
EXTERN struct tm *	TclpLocaltime _ANSI_ARGS_((time_t * clock));
/* 12 */
EXTERN struct tm *	TclpGmtime _ANSI_ARGS_((time_t * clock));
/* 13 */
EXTERN char *		TclpInetNtoa _ANSI_ARGS_((struct in_addr addr));
#endif /* UNIX */
#ifdef __WIN32__
/* 0 */
EXTERN void		TclWinConvertError _ANSI_ARGS_((DWORD errCode));
/* 1 */
EXTERN void		TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode));
/* 2 */
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220




221
222
223
224
225
226
227
				CONST char * path, FSSpecPtr theSpec));
#endif /* MAC_TCL */

typedef struct TclIntPlatStubs {
    int magic;
    struct TclIntPlatStubHooks *hooks;

#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 0 */
    int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
    Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */
    int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */
    int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
    void *reserved5;
    TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
    TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
    int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
    TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */




#endif /* UNIX */
#ifdef __WIN32__
    void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
    void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */
    struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */
    int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */
    HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */







|










>
>
>
>







211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
				CONST char * path, FSSpecPtr theSpec));
#endif /* MAC_TCL */

typedef struct TclIntPlatStubs {
    int magic;
    struct TclIntPlatStubHooks *hooks;

#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 0 */
    int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
    Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */
    int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */
    int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
    void *reserved5;
    TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
    TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
    int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
    TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */
    Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR * dir)); /* 10 */
    struct tm * (*tclpLocaltime) _ANSI_ARGS_((time_t * clock)); /* 11 */
    struct tm * (*tclpGmtime) _ANSI_ARGS_((time_t * clock)); /* 12 */
    char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
    void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
    void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */
    struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */
    int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */
    HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)

/*
 * Inline function declarations:
 */

#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
	(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#endif
#ifndef TclpCloseFile
#define TclpCloseFile \
	(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */







|







302
303
304
305
306
307
308
309
310
311
312
313
314
315
316

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)

/*
 * Inline function declarations:
 */

#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclGetAndDetachPids
#define TclGetAndDetachPids \
	(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#endif
#ifndef TclpCloseFile
#define TclpCloseFile \
	(tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
328
329
330
331
332
333
334
















335
336
337
338
339
340
341
#define TclUnixWaitForFile \
	(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#endif
#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#endif
















#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclWinConvertError
#define TclWinConvertError \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#endif
#ifndef TclWinConvertWSAError







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
#define TclUnixWaitForFile \
	(tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
#endif
#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#endif
#ifndef TclpReaddir
#define TclpReaddir \
	(tclIntPlatStubsPtr->tclpReaddir) /* 10 */
#endif
#ifndef TclpLocaltime
#define TclpLocaltime \
	(tclIntPlatStubsPtr->tclpLocaltime) /* 11 */
#endif
#ifndef TclpGmtime
#define TclpGmtime \
	(tclIntPlatStubsPtr->tclpGmtime) /* 12 */
#endif
#ifndef TclpInetNtoa
#define TclpInetNtoa \
	(tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclWinConvertError
#define TclWinConvertError \
	(tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#endif
#ifndef TclWinConvertWSAError
Changes to generic/tclInterp.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation
 *	and manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInterp.c,v 1.7.6.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <stdio.h>

/*











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation
 *	and manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInterp.c,v 1.7.6.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <stdio.h>

/*
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58










59
60
61
62
63
64
65
 * when the source command is invoked.
 */

typedef struct Alias {
    Tcl_Obj *namePtr;		/* Name of alias command in slave interp. */
    Tcl_Interp *targetInterp;	/* Interp in which target command will be
				 * invoked. */
    Tcl_Obj *prefixPtr;		/* Tcl list making up 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_Command slaveCmd;	/* Source command in slave interpreter,
				 * bound to command that invokes the target
				 * command in the target interpreter. */
    Tcl_HashEntry *aliasEntryPtr;
				/* Entry for the alias hash table in slave.
                                 * This is used by alias deletion to remove
                                 * the alias from the slave interpreter
                                 * alias table. */
    Tcl_HashEntry *targetEntryPtr;
				/* Entry for target command in master.
                                 * This is used in the master interpreter to
                                 * map back from the target command to aliases
                                 * redirecting to it. Random access to this
                                 * hash table is never required - we are using
                                 * a hash table only for convenience. */










} Alias;

/*
 *
 * struct Slave:
 *
 * Used by the "interp" command to record and find information about slave







<
<
<
<
<
<















>
>
>
>
>
>
>
>
>
>







31
32
33
34
35
36
37






38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 * when the source command is invoked.
 */

typedef struct Alias {
    Tcl_Obj *namePtr;		/* Name of alias command in slave interp. */
    Tcl_Interp *targetInterp;	/* Interp in which target command will be
				 * invoked. */






    Tcl_Command slaveCmd;	/* Source command in slave interpreter,
				 * bound to command that invokes the target
				 * command in the target interpreter. */
    Tcl_HashEntry *aliasEntryPtr;
				/* Entry for the alias hash table in slave.
                                 * This is used by alias deletion to remove
                                 * the alias from the slave interpreter
                                 * alias table. */
    Tcl_HashEntry *targetEntryPtr;
				/* Entry for target command in master.
                                 * This is used in the master interpreter to
                                 * map back from the target command to aliases
                                 * redirecting to it. Random access to this
                                 * hash table is never required - we are using
                                 * a hash table only for convenience. */
    int objc;                   /* Count of Tcl_Obj in the prefix of the
				 * target command to be invoked in the
				 * target interpreter. Additional arguments
				 * specified when calling the alias in the
				 * slave interp will be appended to the prefix
				 * before the command is invoked. */
    Tcl_Obj *objPtr;            /* The first actual prefix object - the target
				 * command name; this has to be at the end of the 
				 * structure, which will be extended to accomodate 
				 * the remaining objects in the prefix. */
} Alias;

/*
 *
 * struct Slave:
 *
 * Used by the "interp" command to record and find information about slave
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
    Tcl_Interp *slaveInterp;	/* Interpreter for source command. */
    CONST char *slaveCmd;	/* Command to install in slave. */
    Tcl_Interp *targetInterp;	/* Interpreter for target command. */
    CONST char *targetCmd;	/* Name of target command. */
    int argc;			/* How many additional arguments? */
    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);







|







831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
    Tcl_Interp *slaveInterp;	/* Interpreter for source command. */
    CONST char *slaveCmd;	/* Command to install in slave. */
    Tcl_Interp *targetInterp;	/* Interpreter for target command. */
    CONST char *targetCmd;	/* Name of target command. */
    int argc;			/* How many additional arguments? */
    CONST char * CONST *argv;	/* These are the additional args. */
{
    Tcl_Obj *slaveObjPtr, *targetObjPtr;
    Tcl_Obj **objv;
    int i;
    int result;
    
    objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
925
926
927
928
929
930
931
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
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. */
    char ***argvPtr;			/* (Return) additional arguments. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int i, objc;
    Tcl_Obj **objv;
    
    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "alias \"", aliasName, "\" not found", (char *) NULL);
	return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);


    if (targetInterpPtr != NULL) {
	*targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != NULL) {
	*targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (argcPtr != NULL) {
	*argcPtr = objc - 1;
    }
    if (argvPtr != NULL) {

        *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1));
        for (i = 1; i < objc; i++) {
            *argvPtr[i - 1] = Tcl_GetString(objv[i]);
        }
    }
    return TCL_OK;
}








|















|
>











>
|







929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
        argvPtr)
    Tcl_Interp *interp;			/* Interp to start search from. */
    CONST char *aliasName;			/* Name of alias to find. */
    Tcl_Interp **targetInterpPtr;	/* (Return) target interpreter. */
    CONST char **targetNamePtr;		/* (Return) name of target command. */
    int *argcPtr;			/* (Return) count of addnl args. */
    CONST char ***argvPtr;		/* (Return) additional arguments. */
{
    InterpInfo *iiPtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;
    int i, objc;
    Tcl_Obj **objv;
    
    iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "alias \"", aliasName, "\" not found", (char *) NULL);
	return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != NULL) {
	*targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != NULL) {
	*targetNamePtr = Tcl_GetString(objv[0]);
    }
    if (argcPtr != NULL) {
	*argcPtr = objc - 1;
    }
    if (argvPtr != NULL) {
        *argvPtr = (CONST char **) 
		ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
        for (i = 1; i < objc; i++) {
            *argvPtr[i - 1] = Tcl_GetString(objv[i]);
        }
    }
    return TCL_OK;
}

1001
1002
1003
1004
1005
1006
1007
1008

1009
1010
1011
1012
1013
1014
1015
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "alias \"", aliasName, "\" not found", (char *) NULL);
        return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);


    if (targetInterpPtr != (Tcl_Interp **) NULL) {
        *targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != (CONST char **) NULL) {
        *targetNamePtr = Tcl_GetString(objv[0]);
    }







|
>







1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
    hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "alias \"", aliasName, "\" not found", (char *) NULL);
        return TCL_ERROR;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    objc = aliasPtr->objc;
    objv = &aliasPtr->objPtr;

    if (targetInterpPtr != (Tcl_Interp **) NULL) {
        *targetInterpPtr = aliasPtr->targetInterp;
    }
    if (targetNamePtr != (CONST char **) NULL) {
        *targetNamePtr = Tcl_GetString(objv[0]);
    }
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
     * 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) {
	int objc;
	Tcl_Obj **objv;

        /*
         * If the target of the next alias in the chain is the same as
         * the source alias, we have a loop.
	 */

	Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv);
	aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
                Tcl_GetString(objv[0]),
		Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
		/*flags*/ 0);
        if (aliasCmd == (Tcl_Command) NULL) {
            return TCL_OK;
        }
	aliasCmdPtr = (Command *) aliasCmd;
        if (aliasCmdPtr == cmdPtr) {







<
|






|

|







1078
1079
1080
1081
1082
1083
1084

1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
     * If we encounter the alias we are defining (or renaming to) any in
     * the chain then we have a loop.
     */

    aliasPtr = (Alias *) cmdPtr->objClientData;
    nextAliasPtr = aliasPtr;
    while (1) {

	Tcl_Obj *cmdNamePtr;

        /*
         * If the target of the next alias in the chain is the same as
         * the source alias, we have a loop.
	 */

	cmdNamePtr = nextAliasPtr->objPtr;
	aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
                Tcl_GetString(cmdNamePtr),
		Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
		/*flags*/ 0);
        if (aliasCmd == (Tcl_Command) NULL) {
            return TCL_OK;
        }
	aliasCmdPtr = (Command *) aliasCmd;
        if (aliasCmdPtr == cmdPtr) {
1147
1148
1149
1150
1151
1152
1153


1154
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
{
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;
    int new;
    Target *targetPtr;
    Slave *slavePtr;
    Master *masterPtr;



    aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));

    aliasPtr->namePtr		= namePtr;
    Tcl_IncrRefCount(aliasPtr->namePtr);
    aliasPtr->targetInterp	= masterInterp;
    aliasPtr->prefixPtr		= Tcl_NewListObj(1, &targetNamePtr);


    Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv);




    Tcl_IncrRefCount(aliasPtr->prefixPtr);


    aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
	    Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
	    AliasObjCmdDeleteProc);

    if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) {
	/*
	 * Found an alias loop!  The last call to Tcl_CreateObjCommand made
	 * the alias point to itself.  Delete the command and its alias
	 * record.  Be careful to wipe out its client data first, so the
	 * command doesn't try to delete itself.
	 */

	Command *cmdPtr;
	
	Tcl_DecrRefCount(aliasPtr->namePtr);

	Tcl_DecrRefCount(aliasPtr->prefixPtr);

	
        cmdPtr = (Command *) aliasPtr->slaveCmd;
        cmdPtr->clientData = NULL;
        cmdPtr->deleteProc = NULL;
        cmdPtr->deleteData = NULL;
        Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);








>
>

|
>



|
>
>
|
>
>
>
>
|
>
















>
|
>







1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
{
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;
    int new;
    Target *targetPtr;
    Slave *slavePtr;
    Master *masterPtr;
    int i;
    Tcl_Obj **prefv;

    aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) 
            + objc * sizeof(Tcl_Obj *)));
    aliasPtr->namePtr		= namePtr;
    Tcl_IncrRefCount(aliasPtr->namePtr);
    aliasPtr->targetInterp	= masterInterp;

    aliasPtr->objc = objc + 1;
    prefv = &aliasPtr->objPtr;

    *prefv = targetNamePtr;
    Tcl_IncrRefCount(targetNamePtr);
    for (i = 0; i < objc; i++) {
	*(++prefv) = objv[i];
	Tcl_IncrRefCount(objv[i]);
    }

    aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
	    Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
	    AliasObjCmdDeleteProc);

    if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) {
	/*
	 * Found an alias loop!  The last call to Tcl_CreateObjCommand made
	 * the alias point to itself.  Delete the command and its alias
	 * record.  Be careful to wipe out its client data first, so the
	 * command doesn't try to delete itself.
	 */

	Command *cmdPtr;
	
	Tcl_DecrRefCount(aliasPtr->namePtr);
	for (i = 0; i < objc; i++) {
	    Tcl_DecrRefCount(objv[i]);
	}
	
        cmdPtr = (Command *) aliasPtr->slaveCmd;
        cmdPtr->clientData = NULL;
        cmdPtr->deleteProc = NULL;
        cmdPtr->deleteData = NULL;
        Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);

1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
 *----------------------------------------------------------------------
 */

static int
AliasDelete(interp, slaveInterp, namePtr)
    Tcl_Interp *interp;		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
    Tcl_Obj *namePtr;		/* Name of alias to describe. */
{
    Slave *slavePtr;
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use







|







1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
 *----------------------------------------------------------------------
 */

static int
AliasDelete(interp, slaveInterp, namePtr)
    Tcl_Interp *interp;		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
    Tcl_Obj *namePtr;		/* Name of alias to delete. */
{
    Slave *slavePtr;
    Alias *aliasPtr;
    Tcl_HashEntry *hPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
1312
1313
1314
1315
1316
1317
1318

1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331

1332
1333
1334
1335
1336
1337
1338
1339
    Tcl_Interp *interp;		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
    Tcl_Obj *namePtr;		/* Name of alias to describe. */
{
    Slave *slavePtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;	


    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
        return TCL_OK;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);

    Tcl_SetObjResult(interp, aliasPtr->prefixPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasList --







>













>
|







1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
    Tcl_Interp *interp;		/* Interpreter for result & errors. */
    Tcl_Interp *slaveInterp;	/* Interpreter containing alias. */
    Tcl_Obj *namePtr;		/* Name of alias to describe. */
{
    Slave *slavePtr;
    Tcl_HashEntry *hPtr;
    Alias *aliasPtr;	
    Tcl_Obj *prefixPtr;

    /*
     * If the alias has been renamed in the slave, the master can still use
     * the original name (with which it was created) to find the alias to
     * describe it.
     */

    slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
    hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
    if (hPtr == NULL) {
        return TCL_OK;
    }
    aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
    prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
    Tcl_SetObjResult(interp, prefixPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * AliasList --
1396
1397
1398
1399
1400
1401
1402

1403
1404
1405
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
static int
AliasObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Alias record. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument vector. */	
{

    Tcl_Interp *targetInterp;	
    Alias *aliasPtr;		
    int result, prefc, cmdc;
    Tcl_Obj *cmdPtr;
    Tcl_Obj **prefv, **cmdv;
    
    aliasPtr = (Alias *) clientData;
    targetInterp = aliasPtr->targetInterp;

    Tcl_Preserve((ClientData) targetInterp);

    ((Interp *) targetInterp)->numLevels++;

    Tcl_ResetResult(targetInterp);
    Tcl_AllowExceptions(targetInterp);

    /*
     * Check depth of nested calls with AliasObjCmd: if this gets too large,
     * it's probably because of an infinite loop somewhere.
     */

    if (((Interp *) targetInterp)->numLevels >
	    ((Interp *) targetInterp)->maxNestingDepth) {
	Tcl_AppendToObj(Tcl_GetObjResult(targetInterp),
		"too many nested calls to AliasObjCmd (infinite loop using alias?)", -1);
	result = TCL_ERROR;
	goto done;
    }

    /*
     * Append the arguments to the command prefix and invoke the command
     * in the target interp's global namespace.
     */
     
    Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv);
    cmdPtr = Tcl_NewListObj(prefc, prefv);
    Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1);
    Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv);
    result = TclObjInvoke(targetInterp, cmdc, cmdv,
	    TCL_INVOKE_NO_TRACEBACK);
    Tcl_DecrRefCount(cmdPtr);

    /*
     * Check if we are at the bottom of the stack for the target interpreter.
     * If so, check for special return codes.
     */

    
    if (((Interp *) targetInterp)->numLevels == 0) {
	if (result == TCL_RETURN) {
	    result = TclUpdateReturnInfo((Interp *) targetInterp);
	}
	if ((result != TCL_OK) && (result != TCL_ERROR)) {


	    Tcl_ResetResult(targetInterp);
	    if (result == TCL_BREAK) {

                Tcl_SetObjResult(targetInterp,
                        Tcl_NewStringObj("invoked \"break\" outside of a loop",
                                -1));
	    } else if (result == TCL_CONTINUE) {
                Tcl_SetObjResult(targetInterp,
                        Tcl_NewStringObj(
                            "invoked \"continue\" outside of a loop",
                            -1));
	    } else {
                char buf[32 + TCL_INTEGER_SPACE];



                sprintf(buf, "command returned bad code: %d", result);
                Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));

	    }
	    result = TCL_ERROR;
	}
    }
    done:
    ((Interp *) targetInterp)->numLevels--;
    
    TclTransferResult(targetInterp, result, interp);


    Tcl_Release((ClientData) targetInterp);
    return result;        

}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *







>



<

|



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<





|
|
|
|
<
<
|
|
<
<
<
<
>
|
<
<
<
|
<
>
>
|
<
>
|
|
<
<
|
<
<
<
<
<

>
>
|
|
>
|
|
|
|
<
<
|
<
>
|
<

>







1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426

1427
1428
1429
1430
1431




















1432
1433
1434
1435
1436
1437
1438
1439
1440


1441
1442




1443
1444



1445

1446
1447
1448

1449
1450
1451


1452





1453
1454
1455
1456
1457
1458
1459
1460
1461
1462


1463

1464
1465

1466
1467
1468
1469
1470
1471
1472
1473
1474
static int
AliasObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Alias record. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument vector. */	
{
#define ALIAS_CMDV_PREALLOC 10
    Tcl_Interp *targetInterp;	
    Alias *aliasPtr;		
    int result, prefc, cmdc;

    Tcl_Obj **prefv, **cmdv;
    Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
    aliasPtr = (Alias *) clientData;
    targetInterp = aliasPtr->targetInterp;





















    /*
     * Append the arguments to the command prefix and invoke the command
     * in the target interp's global namespace.
     */
     
    prefc = aliasPtr->objc;
    prefv = &aliasPtr->objPtr;
    cmdc = prefc + objc - 1;
    if (cmdc <= ALIAS_CMDV_PREALLOC) {


	cmdv = cmdArr;
    } else {




	cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
    }





    prefv = &aliasPtr->objPtr;
    memcpy((VOID *) cmdv, (VOID *) prefv, 
            (size_t) (prefc * sizeof(Tcl_Obj *)));

    memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), 
	    (size_t) ((objc-1) * sizeof(Tcl_Obj *)));



    Tcl_ResetResult(targetInterp);






    if (targetInterp != interp) {
	Tcl_Preserve((ClientData) targetInterp);
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
	TclTransferResult(targetInterp, result, interp);	
	Tcl_Release((ClientData) targetInterp);
    } else {
	result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
    }



    if (cmdv != cmdArr) {

	ckfree((char *) cmdv);
    }

    return result;        
#undef ALIAS_CMDV_PREALLOC
}

/*
 *----------------------------------------------------------------------
 *
 * AliasObjCmdDeleteProc --
 *
1500
1501
1502
1503
1504
1505
1506


1507
1508
1509
1510


1511

1512
1513
1514
1515
1516
1517
1518

static void
AliasObjCmdDeleteProc(clientData)
    ClientData clientData;	/* The alias record for this alias. */
{
    Alias *aliasPtr;		
    Target *targetPtr;		



    aliasPtr = (Alias *) clientData;
    
    Tcl_DecrRefCount(aliasPtr->namePtr);


    Tcl_DecrRefCount(aliasPtr->prefixPtr);

    Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);

    targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
    ckfree((char *) targetPtr);
    Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);

    ckfree((char *) aliasPtr);







>
>




>
>
|
>







1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510

static void
AliasObjCmdDeleteProc(clientData)
    ClientData clientData;	/* The alias record for this alias. */
{
    Alias *aliasPtr;		
    Target *targetPtr;		
    int i;
    Tcl_Obj **objv;

    aliasPtr = (Alias *) clientData;
    
    Tcl_DecrRefCount(aliasPtr->namePtr);
    objv = &aliasPtr->objPtr;
    for (i = 0; i < aliasPtr->objc; i++) {
	Tcl_DecrRefCount(objv[i]);
    }
    Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);

    targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
    ckfree((char *) targetPtr);
    Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);

    ckfree((char *) aliasPtr);
Changes to generic/tclLink.c.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLink.c,v 1.3.28.2 2002/06/10 05:33:12 wolfsuit 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







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 *
 * Copyright (c) 1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLink.c,v 1.3.28.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"

/*
 * For each linked variable there is a data structure of the following
 * type, which describes the link and is the clientData for the trace
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#define LINK_BEING_UPDATED	2

/*
 * Forward references to procedures defined later in this file:
 */

static char *		LinkTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, char *name1, CONST char *name2,
			    int flags));
static Tcl_Obj *	ObjValue _ANSI_ARGS_((Link *linkPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinkVar --
 *







|
|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#define LINK_BEING_UPDATED	2

/*
 * Forward references to procedures defined later in this file:
 */

static char *		LinkTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, CONST char *name1, 
                            CONST char *name2, int flags));
static Tcl_Obj *	ObjValue _ANSI_ARGS_((Link *linkPtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinkVar --
 *
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LinkVar(interp, varName, addr, type)
    Tcl_Interp *interp;		/* Interpreter in which varName exists. */
    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;







|







84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
 *
 *----------------------------------------------------------------------
 */

int
Tcl_LinkVar(interp, varName, addr, type)
    Tcl_Interp *interp;		/* Interpreter in which varName exists. */
    CONST char *varName;	/* Name of a global variable in interp. */
    char *addr;			/* Address of a C variable to be linked
				 * to varName. */
    int type;			/* Type of C variable: TCL_LINK_INT, etc. 
				 * Also may have TCL_LINK_READ_ONLY
				 * OR'ed in. */
{
    Tcl_Obj *objPtr;
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UnlinkVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable to unlink. */
    char *varName;		/* Global variable in interp to unlink. */
{
    Link *linkPtr;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
	    LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {
	return;







|







145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UnlinkVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable to unlink. */
    CONST char *varName;	/* Global variable in interp to unlink. */
{
    Link *linkPtr;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
	    LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {
	return;
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UpdateLinkedVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *varName;		/* Name of global variable that is linked. */
{
    Link *linkPtr;
    int savedFlag;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
	    LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {







|







183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UpdateLinkedVar(interp, varName)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of global variable that is linked. */
{
    Link *linkPtr;
    int savedFlag;

    linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
	    LinkTraceProc, (ClientData) NULL);
    if (linkPtr == NULL) {
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
 *----------------------------------------------------------------------
 */

static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Contains information about the link. */
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    char *name1;		/* First part of variable name. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *) clientData;
    int changed, valueLength;
    CONST char *value;
    char **pp, *result;







|







225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
 *----------------------------------------------------------------------
 */

static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Contains information about the link. */
    Tcl_Interp *interp;		/* Interpreter containing Tcl variable. */
    CONST char *name1;		/* First part of variable name. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Miscellaneous additional information. */
{
    Link *linkPtr = (Link *) clientData;
    int changed, valueLength;
    CONST char *value;
    char **pp, *result;
Changes to generic/tclLoad.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same
 *	on all platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoad.c,v 1.6.8.1 2002/02/05 02:22:00 wolfsuit Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded
 * either dynamically (with the "load" command) or statically (as











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclLoad.c --
 *
 *	This file provides the generic portion (those that are the same
 *	on all platforms) of Tcl's dynamic loading facilities.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoad.c,v 1.6.8.2 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"

/*
 * The following structure describes a package that has been loaded
 * either dynamically (with the "load" command) or statically (as
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
				 * package was loaded.  An empty string
				 * means the package is loaded statically.
				 * Malloc-ed. */
    char *packageName;		/* Name of package prefix for the package,
				 * properly capitalized (first letter UC,
				 * others LC), no "_", as in "Net". 
				 * Malloc-ed. */
    ClientData clientData;	/* 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. */







|







28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
				 * package was loaded.  An empty string
				 * means the package is loaded statically.
				 * Malloc-ed. */
    char *packageName;		/* Name of package prefix for the package,
				 * properly capitalized (first letter UC,
				 * others LC), no "_", as in "Net". 
				 * Malloc-ed. */
    Tcl_LoadHandle loadHandle;	/* Token for the loaded file which should be
				 * passed to (*unLoadProcPtr)() when the file
				 * is no longer needed.  If fileName is NULL,
				 * then this field is irrelevant. */
    Tcl_PackageInitProc *initProc;
				/* Initialization procedure to call to
				 * incorporate this package into a trusted
				 * interpreter. */
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
    Tcl_Interp *target;
    LoadedPackage *pkgPtr, *defaultPtr;
    Tcl_DString pkgName, tmp, initName, safeInitName;
    Tcl_PackageInitProc *initProc, *safeInitProc;
    InterpPackage *ipFirstPtr, *ipPtr;
    int code, namesMatch, filesMatch;
    char *p, *fullFileName, *packageName;
    ClientData clientData;
    Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
    Tcl_UniChar ch;
    int offset;

    if ((objc < 2) || (objc > 4)) {
        Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
	return TCL_ERROR;







|







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
    Tcl_Interp *target;
    LoadedPackage *pkgPtr, *defaultPtr;
    Tcl_DString pkgName, tmp, initName, safeInitName;
    Tcl_PackageInitProc *initProc, *safeInitProc;
    InterpPackage *ipFirstPtr, *ipPtr;
    int code, namesMatch, filesMatch;
    char *p, *fullFileName, *packageName;
    Tcl_LoadHandle loadHandle;
    Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
    Tcl_UniChar ch;
    int offset;

    if ((objc < 2) || (objc > 4)) {
        Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
	return TCL_ERROR;
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
	 * Call platform-specific code to load the package and find the
	 * two initialization procedures.
	 */

	Tcl_MutexLock(&packageMutex);
	code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
		Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
		&clientData,&unLoadProcPtr);
	Tcl_MutexUnlock(&packageMutex);
	if (code != TCL_OK) {
	    goto done;
	}
	if (initProc == NULL) {
	    Tcl_AppendResult(interp, "couldn't find procedure ",
		    Tcl_DStringValue(&initName), (char *) NULL);
	    if (unLoadProcPtr != NULL) {
		(*unLoadProcPtr)(clientData);
	    }
	    code = TCL_ERROR;
	    goto done;
	}

	/*
	 * Create a new record to describe this package.
	 */

	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
	pkgPtr->fileName	= (char *) ckalloc((unsigned)
		(strlen(fullFileName) + 1));
	strcpy(pkgPtr->fileName, fullFileName);
	pkgPtr->packageName	= (char *) ckalloc((unsigned)
		(Tcl_DStringLength(&pkgName) + 1));
	strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
	pkgPtr->clientData	= clientData;
	pkgPtr->unLoadProcPtr	= unLoadProcPtr;
	pkgPtr->initProc	= initProc;
	pkgPtr->safeInitProc	= safeInitProc;
	Tcl_MutexLock(&packageMutex);
	pkgPtr->nextPtr		= firstPackagePtr;
	firstPackagePtr		= pkgPtr;
	Tcl_MutexUnlock(&packageMutex);







|








|
















|







336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
	 * Call platform-specific code to load the package and find the
	 * two initialization procedures.
	 */

	Tcl_MutexLock(&packageMutex);
	code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
		Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
		&loadHandle,&unLoadProcPtr);
	Tcl_MutexUnlock(&packageMutex);
	if (code != TCL_OK) {
	    goto done;
	}
	if (initProc == NULL) {
	    Tcl_AppendResult(interp, "couldn't find procedure ",
		    Tcl_DStringValue(&initName), (char *) NULL);
	    if (unLoadProcPtr != NULL) {
		(*unLoadProcPtr)(loadHandle);
	    }
	    code = TCL_ERROR;
	    goto done;
	}

	/*
	 * Create a new record to describe this package.
	 */

	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
	pkgPtr->fileName	= (char *) ckalloc((unsigned)
		(strlen(fullFileName) + 1));
	strcpy(pkgPtr->fileName, fullFileName);
	pkgPtr->packageName	= (char *) ckalloc((unsigned)
		(Tcl_DStringLength(&pkgName) + 1));
	strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
	pkgPtr->loadHandle	= loadHandle;
	pkgPtr->unLoadProcPtr	= unLoadProcPtr;
	pkgPtr->initProc	= initProc;
	pkgPtr->safeInitProc	= safeInitProc;
	Tcl_MutexLock(&packageMutex);
	pkgPtr->nextPtr		= firstPackagePtr;
	firstPackagePtr		= pkgPtr;
	Tcl_MutexUnlock(&packageMutex);
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

    pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
    pkgPtr->fileName		= (char *) ckalloc((unsigned) 1);
    pkgPtr->fileName[0]		= 0;
    pkgPtr->packageName		= (char *) ckalloc((unsigned)
	    (strlen(pkgName) + 1));
    strcpy(pkgPtr->packageName, pkgName);
    pkgPtr->clientData		= NULL;
    pkgPtr->initProc		= initProc;
    pkgPtr->safeInitProc	= safeInitProc;
    Tcl_MutexLock(&packageMutex);
    pkgPtr->nextPtr		= firstPackagePtr;
    firstPackagePtr		= pkgPtr;
    Tcl_MutexUnlock(&packageMutex);








|







486
487
488
489
490
491
492
493
494
495
496
497
498
499
500

    pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
    pkgPtr->fileName		= (char *) ckalloc((unsigned) 1);
    pkgPtr->fileName[0]		= 0;
    pkgPtr->packageName		= (char *) ckalloc((unsigned)
	    (strlen(pkgName) + 1));
    strcpy(pkgPtr->packageName, pkgName);
    pkgPtr->loadHandle		= NULL;
    pkgPtr->initProc		= initProc;
    pkgPtr->safeInitProc	= safeInitProc;
    Tcl_MutexLock(&packageMutex);
    pkgPtr->nextPtr		= firstPackagePtr;
    firstPackagePtr		= pkgPtr;
    Tcl_MutexUnlock(&packageMutex);

663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	 * atexit calls that can't be unregistered.  If you unload
	 * such dlls, you get a core on exit because it wants to
	 * call a function in the dll after it's been unloaded.
	 */
	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
	    if (unLoadProcPtr != NULL) {
	        (*unLoadProcPtr)(pkgPtr->clientData);
	    }
	}
#endif
	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
    }
}







|








663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
	 * atexit calls that can't be unregistered.  If you unload
	 * such dlls, you get a core on exit because it wants to
	 * call a function in the dll after it's been unloaded.
	 */
	if (pkgPtr->fileName[0] != '\0') {
	    Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
	    if (unLoadProcPtr != NULL) {
	        (*unLoadProcPtr)(pkgPtr->loadHandle);
	    }
	}
#endif
	ckfree(pkgPtr->fileName);
	ckfree(pkgPtr->packageName);
	ckfree((char *) pkgPtr);
    }
}
Changes to generic/tclLoadNone.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50



51
52
53
54
55
56
























57
58
59
60
61
62
63
/* 
 * tclLoadNone.c --
 *
 *	This procedure provides a version of the TclLoadFile for use
 *	in systems that don't support dynamic loading; it just returns
 *	an error.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadNone.c,v 1.6.2.1 2002/02/05 02:22:00 wolfsuit Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	This procedure is called to carry out dynamic loading of binary
 *	code;  it is intended for use only on systems that don't support
 *	dynamic loading (it returns an error).
 *
 * Results:
 *	The result is TCL_ERROR, and an error message is left in
 *	the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
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. */
    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 
				 * TclpUnloadFile() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;



{
    Tcl_SetResult(interp,
	    "dynamic loading is not currently available on this system",
	    TCL_STATIC);
    return TCL_ERROR;
}

























/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package












|







|
















|


|
<
<
<
<
<
|

|
|
>
>
>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41





42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
/* 
 * tclLoadNone.c --
 *
 *	This procedure provides a version of the TclLoadFile for use
 *	in systems that don't support dynamic loading; it just returns
 *	an error.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadNone.c,v 1.6.2.2 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	This procedure is called to carry out dynamic loading of binary
 *	code;  it is intended for use only on systems that don't support
 *	dynamic loading (it returns an error).
 *
 * Results:
 *	The result is TCL_ERROR, and an error message is left in
 *	the interp's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    Tcl_SetResult(interp,
	    "dynamic loading is not currently available on this system",
	    TCL_STATIC);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
 *	If the "load" command is invoked without providing a package
100
101
102
103
104
105
106
107
108
109
110
111
112
113
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;    /* ClientData returned by a previous call
			       * to TclpLoadFile().  The clientData is 
			       * a token that represents the loaded 
			       * file. */
{
}







|
|
|
|
|


122
123
124
125
126
127
128
129
130
131
132
133
134
135
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}
Changes to generic/tclNamesp.c.
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.25.8.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"

/*
 * Flag passed to TclGetNamespaceForQualName to indicate that it should
 * search for a namespace rather than a command or variable inside a







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   mmclennan@lucent.com
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNamesp.c,v 1.25.8.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"

/*
 * Flag passed to TclGetNamespaceForQualName to indicate that it should
 * search for a namespace rather than a command or variable inside a
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
 *----------------------------------------------------------------------
 */

Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		 /* The interpreter in which to find the
				  * variable. */
    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







|







2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
 *----------------------------------------------------------------------
 */

Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
    Tcl_Interp *interp;		 /* The interpreter in which to find the
				  * variable. */
    CONST char *name;		 /* Variable's name. If it starts with "::",
				  * will be looked up in global namespace.
				  * Else, looked up first in contextNsPtr
				  * (current namespace if contextNsPtr is
				  * NULL), then in global namespace. */
    Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
				  * Otherwise, points to namespace in which
				  * to resolve name. If NULL, look up name
Changes to generic/tclNotify.c.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNotify.c,v 1.7.18.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

extern TclStubs tclStubs;








|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclNotify.c,v 1.7.18.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

extern TclStubs tclStubs;

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
TclInitNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&listLock);

    tsdPtr->threadId = Tcl_GetCurrentThread();
    if (tclStubs.tcl_InitNotifier == Tcl_InitNotifier) {
        tsdPtr->clientData = Tcl_InitNotifier();
    } else {
        tsdPtr->clientData = tclStubs.tcl_InitNotifier();
    }
    tsdPtr->nextPtr = firstNotifierPtr;
    firstNotifierPtr = tsdPtr;

    Tcl_MutexUnlock(&listLock);
}

/*







<
<
<
|
<







112
113
114
115
116
117
118



119

120
121
122
123
124
125
126
TclInitNotifier()
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    Tcl_MutexLock(&listLock);

    tsdPtr->threadId = Tcl_GetCurrentThread();



    tsdPtr->clientData = tclStubs.tcl_InitNotifier();

    tsdPtr->nextPtr = firstNotifierPtr;
    firstNotifierPtr = tsdPtr;

    Tcl_MutexUnlock(&listLock);
}

/*
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
    }
    tsdPtr->firstEventPtr = NULL;
    tsdPtr->lastEventPtr = NULL;
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));

    Tcl_MutexLock(&listLock);

    if (tclStubs.tcl_FinalizeNotifier == Tcl_FinalizeNotifier) {
        Tcl_FinalizeNotifier(tsdPtr->clientData);
    } else {
        tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
    }

    Tcl_MutexFinalize(&(tsdPtr->queueMutex));
    for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
	 prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
	if (*prevPtrPtr == tsdPtr) {
	    *prevPtrPtr = tsdPtr->nextPtr;
	    break;
	}







<
<
<
|
<
<







156
157
158
159
160
161
162



163


164
165
166
167
168
169
170
    }
    tsdPtr->firstEventPtr = NULL;
    tsdPtr->lastEventPtr = NULL;
    Tcl_MutexUnlock(&(tsdPtr->queueMutex));

    Tcl_MutexLock(&listLock);




    tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);


    Tcl_MutexFinalize(&(tsdPtr->queueMutex));
    for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
	 prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
	if (*prevPtrPtr == tsdPtr) {
	    *prevPtrPtr = tsdPtr->nextPtr;
	    break;
	}
Changes to generic/tclObj.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclObj.c --
 *
 *	This file contains Tcl object-related procedures that are used by
 * 	many Tcl commands.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.23.8.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tclPort.h"

/*













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclObj.c --
 *
 *	This file contains Tcl object-related procedures that are used by
 * 	many Tcl commands.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2001 by ActiveState Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.23.8.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tclPort.h"

/*
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
 * The structure below defines the command name Tcl object type by means of
 * procedures that can be invoked by generic object code. Objects of this
 * type cache the Command pointer that results from looking up command names
 * in the command hashtable. Such objects appear as the zeroth ("command
 * name") argument in a Tcl command.
 */

Tcl_ObjType tclCmdNameType = {
    "cmdName",				/* name */
    FreeCmdNameInternalRep,		/* freeIntRepProc */
    DupCmdNameInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetCmdNameFromAny			/* setFromAnyProc */
};








|







152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
 * The structure below defines the command name Tcl object type by means of
 * procedures that can be invoked by generic object code. Objects of this
 * type cache the Command pointer that results from looking up command names
 * in the command hashtable. Such objects appear as the zeroth ("command
 * name") argument in a Tcl command.
 */

static Tcl_ObjType tclCmdNameType = {
    "cmdName",				/* name */
    FreeCmdNameInternalRep,		/* freeIntRepProc */
    DupCmdNameInternalRep,		/* dupIntRepProc */
    (Tcl_UpdateStringProc *) NULL,	/* updateStringProc */
    SetCmdNameFromAny			/* setFromAnyProc */
};

512
513
514
515
516
517
518
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

Tcl_Obj *
Tcl_NewObj()
{
    register Tcl_Obj *objPtr;

    /*
     * Allocate the object using the list of free Tcl_Obj structs
     * we maintain.
     */

    Tcl_MutexLock(&tclObjMutex);
#ifdef PURIFY
    objPtr = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj));
#else
    if (tclFreeObjList == NULL) {
	TclAllocateFreeObjects();
    }
    objPtr = tclFreeObjList;
    tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
#endif
    objPtr->refCount = 0;
    objPtr->bytes    = tclEmptyStringRep;
    objPtr->length   = 0;
    objPtr->typePtr  = NULL;
#ifdef TCL_COMPILE_STATS
    tclObjsAlloced++;
#endif /* TCL_COMPILE_STATS */
    Tcl_MutexUnlock(&tclObjMutex);
    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *







|
|


<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<







512
513
514
515
516
517
518
519
520
521
522










523







524
525
526
527
528
529
530

Tcl_Obj *
Tcl_NewObj()
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the
     * correct allocator.
     */











    TclNewObj(objPtr);







    return objPtr;
}
#endif /* TCL_MEM_DEBUG */

/*
 *----------------------------------------------------------------------
 *
577
578
579
580
581
582
583
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
				 * procedure; used for debugging. */
    register int line;		/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    /*
     * If debugging Tcl's memory usage, allocate the object using ckalloc.
     * Otherwise, allocate it using the list of free Tcl_Obj structs we
     * maintain.
     */

    objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
    objPtr->refCount = 0;
    objPtr->bytes    = tclEmptyStringRep;
    objPtr->length   = 0;
    objPtr->typePtr  = NULL;
#ifdef TCL_COMPILE_STATS
    Tcl_MutexLock(&tclObjMutex);
    tclObjsAlloced++;
    Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_COMPILE_STATS */
    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







|
|
<


|
<
<
<
<
<
<
<
<
<


<







560
561
562
563
564
565
566
567
568

569
570
571









572
573

574
575
576
577
578
579
580
				 * procedure; used for debugging. */
    register int line;		/* Line number in the source file; used
				 * for debugging. */
{
    register Tcl_Obj *objPtr;

    /*
     * Use the macro defined in tclInt.h - it will use the
     * correct allocator.

     */

    TclDbNewObj(objPtr, file, line);









    return objPtr;
}

#else /* if not TCL_MEM_DEBUG */

Tcl_Obj *
Tcl_DbNewObj(file, line)
    CONST char *file;		/* The name of the source file calling this
				 * procedure; used for debugging. */
    int line;			/* Line number in the source file; used
1068
1069
1070
1071
1072
1073
1074



1075


1076
1077
1078
1079
1080
1081
1082
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get boolean. */
    register int *boolPtr;	/* Place to store resulting boolean. */
{
    register int result;




    result = SetBooleanFromAny(interp, objPtr);


    if (result == TCL_OK) {
	*boolPtr = (int) objPtr->internalRep.longValue;
    }
    return result;
}

/*







>
>
>
|
>
>







1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
    Tcl_Interp *interp; 	/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr;	/* The object from which to get boolean. */
    register int *boolPtr;	/* Place to store resulting boolean. */
{
    register int result;

    if (objPtr->typePtr == &tclBooleanType) {
	result = TCL_OK;
    } else {
	result = SetBooleanFromAny(interp, objPtr);
    }

    if (result == TCL_OK) {
	*boolPtr = (int) objPtr->internalRep.longValue;
    }
    return result;
}

/*
1110
1111
1112
1113
1114
1115
1116
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
    char lowerCase[10];
    int newBool, length;
    register int i;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */

    string = Tcl_GetStringFromObj(objPtr, &length);















    /*
     * Copy the string converting its characters to lower case.
     */

    for (i = 0;  (i < 9) && (i < length);  i++) {
	c = string[i];
	/*
	 * Weed out international characters so we can safely operate
	 * on single bytes.
	 */

	if (c & 0x80) {
	    goto badBoolean;
	}
	if (Tcl_UniCharIsUpper(UCHAR(c))) {
	    c = (char) Tcl_UniCharToLower(UCHAR(c));
	}
	lowerCase[i] = c;
    }
    lowerCase[i] = 0;

    /*
     * Parse the string as a boolean. We use an implementation here that
     * doesn't report errors in interp if interp is NULL.
     */

    c = lowerCase[0];
    if ((c == '0') && (lowerCase[1] == '\0')) {
	newBool = 0;
    } else if ((c == '1') && (lowerCase[1] == '\0')) {
	newBool = 1;
    } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
	newBool = 1;
    } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
	newBool = 0;
    } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
	newBool = 1;
    } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
	newBool = 0;
    } else if ((c == 'o') && (length >= 2)) {
	if (strncmp(lowerCase, "on", (size_t) length) == 0) {
	    newBool = 1;
	} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
	    newBool = 0;
	} else {
	    goto badBoolean;
	}
    } else {
	double dbl;
	/*
	 * Boolean values can be extracted from ints or doubles.  Note
	 * that we don't use strtoul or strtoull here because we don't
	 * care about what the value is, just whether it is equal to
	 * zero or not.
	 */
#ifdef TCL_WIDE_INT_IS_LONG
	newBool = strtol(string, &end, 0);
	if (end != string) {
	    /*
	     * Make sure the string has no garbage after the end of
	     * the int.
	     */
	    while ((end < (string+length))
		   && isspace(UCHAR(*end))) { /* INTL: ISO only */
		end++;
	    }
	    if (end == (string+length)) {
		newBool = (newBool != 0);
		goto goodBoolean;
	    }
	}
#else /* !TCL_WIDE_INT_IS_LONG */
	Tcl_WideInt wide = strtoll(string, &end, 0);
	if (end != string) {
	    /*
	     * Make sure the string has no garbage after the end of
	     * the wide int.
	     */
	    while ((end < (string+length))
		   && isspace(UCHAR(*end))) { /* INTL: ISO only */
		end++;
	    }
	    if (end == (string+length)) {
		newBool = (wide != Tcl_LongAsWide(0));
		goto goodBoolean;
	    }
	}
#endif /* TCL_WIDE_INT_IS_LONG */
        /*
         * Still might be a string containing the characters representing an
         * int or double that wasn't handled above. This would be a string
         * like "27" or "1.0" that is non-zero and not "1". Such a string
         * whould result in the boolean value true. We try converting to
         * double. If that succeeds and the resulting double is non-zero, we
         * have a "true". Note that numbers can't have embedded NULLs.
	 */

	dbl = strtod(string, &end);
	if (end == string) {
	    goto badBoolean;
	}

	/*
	 * Make sure the string has no garbage after the end of the double.
	 */
	
	while ((end < (string+length))
		&& isspace(UCHAR(*end))) { /* INTL: ISO only */
	    end++;
	}
	if (end != (string+length)) {
	    goto badBoolean;
	}
	newBool = (dbl != 0.0);

    }

    /*
     * Free the old internalRep before setting the new one. We do this as
     * late as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */







|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>







1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
    char lowerCase[10];
    int newBool, length;
    register int i;

    /*
     * Get the string representation. Make it up-to-date if necessary.
     */
    
    string = Tcl_GetStringFromObj(objPtr, &length);

    /*
     * Use the obvious shortcuts for numerical values; if objPtr is not
     * of numerical type, parse its string rep.
     */
	
    if (objPtr->typePtr == &tclIntType) {
	newBool = (objPtr->internalRep.longValue != 0);
    } else if (objPtr->typePtr == &tclDoubleType) {
	newBool = (objPtr->internalRep.doubleValue != 0.0);
#ifndef TCL_WIDE_INT_IS_LONG
    } else if (objPtr->typePtr == &tclWideIntType) {
	newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0));
#endif /* TCL_WIDE_INT_IS_LONG */
    } else {
	/*
	 * Copy the string converting its characters to lower case.
	 */
	
	for (i = 0;  (i < 9) && (i < length);  i++) {
	    c = string[i];
	    /*
	     * Weed out international characters so we can safely operate
	     * on single bytes.
	     */
	    
	    if (c & 0x80) {
		goto badBoolean;
	    }
	    if (Tcl_UniCharIsUpper(UCHAR(c))) {
		c = (char) Tcl_UniCharToLower(UCHAR(c));
	    }
	    lowerCase[i] = c;
	}
	lowerCase[i] = 0;
	
	/*
	 * Parse the string as a boolean. We use an implementation here that
	 * doesn't report errors in interp if interp is NULL.
	 */
	
	c = lowerCase[0];
	if ((c == '0') && (lowerCase[1] == '\0')) {
	    newBool = 0;
	} else if ((c == '1') && (lowerCase[1] == '\0')) {
	    newBool = 1;
	} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
	    newBool = 1;
	} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
	    newBool = 0;
	} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
	    newBool = 1;
	} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
	    newBool = 0;
	} else if ((c == 'o') && (length >= 2)) {
	    if (strncmp(lowerCase, "on", (size_t) length) == 0) {
		newBool = 1;
	    } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
		newBool = 0;
	    } else {
		goto badBoolean;
	    }
	} else {
	    double dbl;
	    /*
	     * Boolean values can be extracted from ints or doubles.  Note
	     * that we don't use strtoul or strtoull here because we don't
	     * care about what the value is, just whether it is equal to
	     * zero or not.
	     */
#ifdef TCL_WIDE_INT_IS_LONG
	    newBool = strtol(string, &end, 0);
	    if (end != string) {
		/*
		 * Make sure the string has no garbage after the end of
		 * the int.
		 */
		while ((end < (string+length))
		       && isspace(UCHAR(*end))) { /* INTL: ISO only */
		    end++;
		}
		if (end == (string+length)) {
		    newBool = (newBool != 0);
		    goto goodBoolean;
		}
	    }
#else /* !TCL_WIDE_INT_IS_LONG */
	    Tcl_WideInt wide = strtoll(string, &end, 0);
	    if (end != string) {
		/*
		 * Make sure the string has no garbage after the end of
		 * the wide int.
		 */
		while ((end < (string+length))
		       && isspace(UCHAR(*end))) { /* INTL: ISO only */
		    end++;
		}
		if (end == (string+length)) {
		    newBool = (wide != Tcl_LongAsWide(0));
		    goto goodBoolean;
		}
	    }
#endif /* TCL_WIDE_INT_IS_LONG */
	    /*
	     * Still might be a string containing the characters representing an
	     * int or double that wasn't handled above. This would be a string
	     * like "27" or "1.0" that is non-zero and not "1". Such a string
	     * would result in the boolean value true. We try converting to
	     * double. If that succeeds and the resulting double is non-zero, we
	     * have a "true". Note that numbers can't have embedded NULLs.
	     */
	    
	    dbl = strtod(string, &end);
	    if (end == string) {
		goto badBoolean;
	    }
	    
	    /*
	     * Make sure the string has no garbage after the end of the double.
	     */
	    
	    while ((end < (string+length))
		   && isspace(UCHAR(*end))) { /* INTL: ISO only */
		end++;
	    }
	    if (end != (string+length)) {
		goto badBoolean;
	    }
	    newBool = (dbl != 0.0);
	}
    }

    /*
     * Free the old internalRep before setting the new one. We do this as
     * late as possible to allow the conversion code, in particular
     * Tcl_GetStringFromObj, to use that old internalRep.
     */
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
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
				 * if contextNsPtr is NULL, then in global
				 * namespace. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedCmdName *resPtr;
    register Command *cmdPtr;
    Namespace *currNsPtr;
    int result;
    CallFrame *savedFramePtr;







|
<
|







2840
2841
2842
2843
2844
2845
2846
2847

2848
2849
2850
2851
2852
2853
2854
2855
Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
    Tcl_Interp *interp;		/* The interpreter in which to resolve the
				 * command and to report errors. */
    register Tcl_Obj *objPtr;	/* The object containing the command's
				 * name. If the name starts with "::", will
				 * be looked up in global namespace. Else,
				 * looked up first in the current namespace,

				 * then in global namespace. */
{
    Interp *iPtr = (Interp *) interp;
    register ResolvedCmdName *resPtr;
    register Command *cmdPtr;
    Namespace *currNsPtr;
    int result;
    CallFrame *savedFramePtr;
Changes to generic/tclParse.c.
1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
/* 
 * tclParse.c --
 *
 *	This file contains procedures that parse Tcl scripts.  They
 *	do so in a general-purpose fashion that can be used for many
 *	different purposes, including compilation, direct execution,
 *	code analysis, etc.  
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParse.c,v 1.16.4.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The following table provides parsing information about each possible
 * 8-bit character.  The table is designed to be referenced with either
 * signed or unsigned characters, so it has 384 entries.  The first 128
 * entries correspond to negative character values, the next 256 correspond
 * to positive character values.  The last 128 entries are identical to the
 * first 128.  The table is always indexed with a 128-byte offset (the 128th
 * entry corresponds to a character value of 0).
 *
 * The macro CHAR_TYPE is used to index into the table and return
 * information about its character argument.  The following return
 * values are defined.
 *
 * TYPE_NORMAL -	All characters that don't have special significance
 *			to the Tcl parser.
 * TYPE_SPACE -		The character is a whitespace character other
 *			than newline.
 * TYPE_COMMAND_END -	Character is newline or semicolon.
 * TYPE_SUBS -		Character begins a substitution or has other
 *			special meaning in ParseTokens: backslash, dollar
 *			sign, open bracket, or null.
 * 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) (typeTable+128)[(int)(c)]

char typeTable[] = {
    /*
     * Negative character values, from -128 to -1:
     */

    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,










>




|


















|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|

|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
/* 
 * tclParse.c --
 *
 *	This file contains procedures that parse Tcl scripts.  They
 *	do so in a general-purpose fashion that can be used for many
 *	different purposes, including compilation, direct execution,
 *	code analysis, etc.  
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 * Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParse.c,v 1.16.4.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The following table provides parsing information about each possible
 * 8-bit character.  The table is designed to be referenced with either
 * signed or unsigned characters, so it has 384 entries.  The first 128
 * entries correspond to negative character values, the next 256 correspond
 * to positive character values.  The last 128 entries are identical to the
 * first 128.  The table is always indexed with a 128-byte offset (the 128th
 * entry corresponds to a character value of 0).
 *
 * The macro CHAR_TYPE is used to index into the table and return
 * information about its character argument.  The following return
 * values are defined.
 *
 * TYPE_NORMAL -        All characters that don't have special significance
 *                      to the Tcl parser.
 * TYPE_SPACE -         The character is a whitespace character other
 *                      than newline.
 * TYPE_COMMAND_END -   Character is newline or semicolon.
 * TYPE_SUBS -          Character begins a substitution or has other
 *                      special meaning in ParseTokens: backslash, dollar
 *                      sign, or open bracket.
 * TYPE_QUOTE -         Character is a double quote.
 * TYPE_CLOSE_PAREN -   Character is a right parenthesis.
 * TYPE_CLOSE_BRACK -   Character is a right square bracket.
 * TYPE_BRACE -         Character is a curly brace (either left or right).
 */

#define TYPE_NORMAL             0
#define TYPE_SPACE              0x1
#define TYPE_COMMAND_END        0x2
#define TYPE_SUBS               0x4
#define TYPE_QUOTE              0x8
#define TYPE_CLOSE_PAREN        0x10
#define TYPE_CLOSE_BRACK        0x20
#define TYPE_BRACE              0x40

#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]

static CONST char charTypeTable[] = {
    /*
     * Negative character values, from -128 to -1:
     */

    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
169
170
171
172
173
174
175
176
177


178
179
180
181
182
183
184
185
186
187
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

/*
 * Prototypes for local procedures defined in this file:
 */

static int		CommandComplete _ANSI_ARGS_((char *script,
			    int length));


static int		ParseTokens _ANSI_ARGS_((char *src, int mask,
			    Tcl_Parse *parsePtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseCommand --
 *
 *	Given a string, this procedure parses the first Tcl command
 *	in the string and returns information about the structure of







|
|
>
>
|
|
|







170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
    TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,      TYPE_NORMAL,
};

/*
 * Prototypes for local procedures defined in this file:
 */

static int		CommandComplete _ANSI_ARGS_((CONST char *script,
			    int numBytes));
static int		ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
			    Tcl_Parse *parsePtr));
static int		ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
			    int mask, Tcl_Parse *parsePtr));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseCommand --
 *
 *	Given a string, this procedure parses the first Tcl command
 *	in the string and returns information about the structure of
205
206
207
208
209
210
211
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
 */

int
Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    char *string;		/* First character of string containing
				 * one or more Tcl commands.  The string
				 * must be in writable memory and must
				 * have one additional byte of space at
				 * string[length] where we can
				 * temporarily store a 0 sentinel
				 * character. */
    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 char *src;		/* Points to current character
				 * in the command. */
    int 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. */
    char utfBytes[TCL_UTF_MAX];	/* Holds result of backslash substitution. */
    int terminators;		/* CHAR_TYPE bits that indicate the end
				 * of a command. */
    char *termPtr;		/* Set by Tcl_ParseBraces/QuotedString to
				 * point to char after terminating one. */

    int length, savedChar;






    if (numBytes < 0) {
	numBytes = (string? strlen(string) : 0);
    }
    parsePtr->commentStart = NULL;
    parsePtr->commentSize = 0;
    parsePtr->commandStart = NULL;
    parsePtr->commandSize = 0;
    parsePtr->numWords = 0;
    parsePtr->tokenPtr = parsePtr->staticTokens;







|
|
<
<
<
<
<
|












|

|


<


|

>
|
>
>
>
|
>
|

|







208
209
210
211
212
213
214
215
216





217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234

235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
 */

int
Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* First character of string containing
				 * one or more Tcl commands. */





    register int numBytes;	/* Total number of bytes in string.  If < 0,
				 * the script consists of all bytes up to 
				 * the first null character. */
    int nested;			/* Non-zero means this is a nested command:
				 * close bracket should be considered
				 * a command terminator. If zero, then close
				 * bracket has no special meaning. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information
				 * about the parsed command; any previous
				 * information in the structure is
				 * ignored. */
{
    register CONST char *src;	/* Points to current character
				 * in the command. */
    char type;			/* Result returned by CHAR_TYPE(*src). */
    Tcl_Token *tokenPtr;	/* Pointer to token being filled in. */
    int wordIndex;		/* Index of word token for current word. */

    int terminators;		/* CHAR_TYPE bits that indicate the end
				 * of a command. */
    CONST char *termPtr;	/* Set by Tcl_ParseBraces/QuotedString to
				 * point to char after terminating one. */
    int scanned;
    
    if ((string == NULL) && (numBytes>0)) {
	if (interp != NULL) {
	    Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
	}
	return TCL_ERROR;
    }
    if (numBytes < 0) {
	numBytes = strlen(string);
    }
    parsePtr->commentStart = NULL;
    parsePtr->commentSize = 0;
    parsePtr->commandStart = NULL;
    parsePtr->commandSize = 0;
    parsePtr->numWords = 0;
    parsePtr->tokenPtr = parsePtr->staticTokens;
261
262
263
264
265
266
267
268
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
    parsePtr->errorType = TCL_PARSE_SUCCESS;
    if (nested != 0) {
	terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
    } else {
	terminators = TYPE_COMMAND_END;
    }

    /*
     * Temporarily overwrite the character just after the end of the
     * string with a 0 byte.  This acts as a sentinel and reduces the
     * number of places where we have to check for the end of the
     * input string.  The original value of the byte is restored at
     * the end of the parse.
     */

    savedChar = string[numBytes];
    if (savedChar != 0) {
	string[numBytes] = 0;
    }

    /*
     * Parse any leading space and comments before the first word of the
     * command.
     */

    src = string;
    while (1) {
	while ((CHAR_TYPE(*src) == TYPE_SPACE) || (*src == '\n')) {
	    src++;
	}
	if ((*src == '\\') && (src[1] == '\n')) {
	    /*
	     * Skip backslash-newline sequence: it should be treated
	     * just like white space.
	     */

	    if ((src + 2) == parsePtr->end) {
		parsePtr->incomplete = 1;
	    }
	    src += 2;
	    continue;
	}
	if (*src != '#') {
	    break;
	}
	if (parsePtr->commentStart == NULL) {
	    parsePtr->commentStart = src;
	}
	while (1) {
	    if (src == parsePtr->end) {
		if (nested) {
		    parsePtr->incomplete = nested;
		}
		parsePtr->commentSize = src - parsePtr->commentStart;
		break;
	    } else if (*src == '\\') {
		if ((src[1] == '\n') && ((src + 2) == parsePtr->end)) {
		    parsePtr->incomplete = 1;
		}
		Tcl_UtfBackslash(src, &length, utfBytes);
		src += length;
	    } else if (*src == '\n') {
		src++;
		parsePtr->commentSize = src - parsePtr->commentStart;
		break;
	    } else {
		src++;
	    }
	}
    }

    /*
     * The following loop parses the words of the command, one word
     * in each iteration through the loop.
     */








<
<
<
<
<
<
<
<
<
<
<
<
<




<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
|
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







263
264
265
266
267
268
269
270













271
272
273
274










275



276


277







278
279
















280
281
282
283
284
285
286
    parsePtr->errorType = TCL_PARSE_SUCCESS;
    if (nested != 0) {
	terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
    } else {
	terminators = TYPE_COMMAND_END;
    }

    /*













     * Parse any leading space and comments before the first word of the
     * command.
     */











    scanned = ParseComment(string, numBytes, parsePtr);



    src = (string + scanned); numBytes -= scanned;


    if (numBytes == 0) {







	if (nested) {
	    parsePtr->incomplete = nested;
















	}
    }

    /*
     * The following loop parses the words of the command, one word
     * in each iteration through the loop.
     */
348
349
350
351
352
353
354
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
	tokenPtr->type = TCL_TOKEN_WORD;

	/*
	 * Skip white space before the word. Also skip a backslash-newline
	 * sequence: it should be treated just like white space.
	 */

	while (1) {
	    type = CHAR_TYPE(*src);
	    if (type == TYPE_SPACE) {
		src++;
		continue;
	    } else if ((*src == '\\') && (src[1] == '\n')) {
		if ((src + 2) == parsePtr->end) {
		    parsePtr->incomplete = 1;
		}
		Tcl_UtfBackslash(src, &length, utfBytes);
		src += length;
		continue;
	    }
	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++;
	    break;
	}
	if (src == parsePtr->end) {
	    break;
	}
	tokenPtr->start = src;
	parsePtr->numTokens++;
	parsePtr->numWords++;

	/*
	 * At this point the word can have one of three forms: something
	 * enclosed in quotes, something enclosed in braces, or an
	 * unquoted word (anything else).
	 */

	if (*src == '"') {
	    if (Tcl_ParseQuotedString(interp, src, (parsePtr->end - src),
	            parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr;
	} else if (*src == '{') {
	    if (Tcl_ParseBraces(interp, src, (parsePtr->end - src),
	            parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr;
	} else {
	    /*
	     * This is an unquoted word.  Call ParseTokens and let it do
	     * all of the work.
	     */

	    if (ParseTokens(src, TYPE_SPACE|terminators, 
		    parsePtr) != TCL_OK) {
		goto error;
	    }
	    src = parsePtr->term;
	}

	/*
	 * 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.
	 */







<
<
<
<
<
<
<
|
<
<
|
|
<







<
<
<











|
|


|

|
|


|






|



|







299
300
301
302
303
304
305







306


307
308

309
310
311
312
313
314
315



316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
	tokenPtr->type = TCL_TOKEN_WORD;

	/*
	 * Skip white space before the word. Also skip a backslash-newline
	 * sequence: it should be treated just like white space.
	 */








	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);


	src += scanned; numBytes -= scanned;
	if (numBytes == 0) {

	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++;
	    break;
	}



	tokenPtr->start = src;
	parsePtr->numTokens++;
	parsePtr->numWords++;

	/*
	 * At this point the word can have one of three forms: something
	 * enclosed in quotes, something enclosed in braces, or an
	 * unquoted word (anything else).
	 */

	if (*src == '"') {
	    if (Tcl_ParseQuotedString(interp, src, numBytes,
		    parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr; numBytes = parsePtr->end - src;
	} else if (*src == '{') {
	    if (Tcl_ParseBraces(interp, src, numBytes,
		    parsePtr, 1, &termPtr) != TCL_OK) {
		goto error;
	    }
	    src = termPtr; numBytes = parsePtr->end - src;
	} else {
	    /*
	     * This is an unquoted word.  Call ParseTokens and let it do
	     * all of the work.
	     */

	    if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
		    parsePtr) != TCL_OK) {
		goto error;
	    }
	    src = parsePtr->term; numBytes = parsePtr->end - src;
	}

	/*
	 * Finish filling in the token for the word and check for the
	 * special case of a word consisting of a single range of
	 * literal text.
	 */
427
428
429
430
431
432
433
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
	/*
	 * 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.
	 */

	type = CHAR_TYPE(*src);
	if (type == TYPE_SPACE) {
	    src++;
	    continue;
	} else {
	    /*
	     * Backslash-newline (and any following white space) must be
	     * treated as if it were a space character.
	     */

	    if ((*src == '\\') && (src[1] == '\n')) {
		if ((src + 2) == parsePtr->end) {
		    parsePtr->incomplete = 1;
		}
		Tcl_UtfBackslash(src, &length, utfBytes);
		src += length;
		continue;
	    }
	}



	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++;
	    break;
	}
	if (src == parsePtr->end) {
	    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;
    if (savedChar != 0) {
	string[numBytes] = (char) savedChar;
    }
    return TCL_OK;

    error:
    if (savedChar != 0) {
	string[numBytes] = (char) savedChar;
    }
    Tcl_FreeParse(parsePtr);
    if (parsePtr->commandStart == NULL) {
	parsePtr->commandStart = string;
    }
    parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
    return TCL_ERROR;
}
























































































































































































































































































































































/*
 *----------------------------------------------------------------------
 *
 * ParseTokens --
 *
 *	This procedure forms the heart of the Tcl parser.  It parses one
 *	or more tokens from a string, up to a termination point
 *	specified by the caller.  This procedure is used to parse
 *	unquoted command words (those not in quotes or braces), words in
 *	quotes, and array indices for variables.

 *
 * Results:
 *	Tokens are added to parsePtr and parsePtr->term is filled in
 *	with the address of the character that terminated the parse (the
 *	first one whose CHAR_TYPE matched mask or the character at
 *	parsePtr->end).  The return value is TCL_OK if the parse
 *	completed successfully and TCL_ERROR otherwise.  If a parse
 *	error occurs and parsePtr->interp isn't NULL, then an error
 *	message is left in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(src, mask, parsePtr)
    register char *src;		/* First character to parse. */

    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. */
{

    int type, originalTokens, varToken;
    char utfBytes[TCL_UTF_MAX];
    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 (1) {
	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	type = CHAR_TYPE(*src);
	if (type & mask) {
	    break;
	}

	if ((type & TYPE_SUBS) == 0) {
	    /*
	     * This is a simple range of characters.  Scan to find the end
	     * of the range.
	     */

	    while (1) {
		src++;
		if (CHAR_TYPE(*src) & (mask | TYPE_SUBS)) {
		    break;
		}

	    }
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '$') {
	    /*
	     * This is a variable reference.  Call Tcl_ParseVarName to do
	     * all the dirty work of parsing the name.
	     */

	    varToken = parsePtr->numTokens;
	    if (Tcl_ParseVarName(parsePtr->interp, src, parsePtr->end - src,
		    parsePtr, 1) != TCL_OK) {
		return TCL_ERROR;
	    }
	    src += parsePtr->tokenPtr[varToken].size;

	} else if (*src == '[') {
	    /*
	     * Command substitution.  Call Tcl_ParseCommand recursively
	     * (and repeatedly) to parse the nested command(s), then
	     * throw away the parse information.
	     */

	    src++;
	    while (1) {
		if (Tcl_ParseCommand(parsePtr->interp, src,
			parsePtr->end - src, 1, &nested) != TCL_OK) {
		    parsePtr->errorType = nested.errorType;
		    parsePtr->term = nested.term;
		    parsePtr->incomplete = nested.incomplete;
		    return TCL_ERROR;
		}
		src = nested.commandStart + nested.commandSize;

		if (nested.tokenPtr != nested.staticTokens) {
		    ckfree((char *) nested.tokenPtr);
		}
		if ((*nested.term == ']') && !nested.incomplete) {
		    break;
		}
		if (src == parsePtr->end) {
		    if (parsePtr->interp != NULL) {
			Tcl_SetResult(parsePtr->interp,
			    "missing close-bracket", TCL_STATIC);
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    return TCL_ERROR;
		}
	    }
	    tokenPtr->type = TCL_TOKEN_COMMAND;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '\\') {
	    /*
	     * Backslash substitution.
	     */










	    if (src[1] == '\n') {
		if ((src + 2) == parsePtr->end) {
		    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) {



		    break;
		}
	    }

	    tokenPtr->type = TCL_TOKEN_BS;
	    Tcl_UtfBackslash(src, &tokenPtr->size, utfBytes);
	    parsePtr->numTokens++;
	    src += tokenPtr->size;

	} else if (*src == 0) {
	    /*
	     * We encountered a null character.  If it is the null
	     * character at the end of the string, then return.
	     * Otherwise generate a text token for the single
	     * character.
	     */

	    if (src == parsePtr->end) {
		break;
	    }
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = 1;
	    parsePtr->numTokens++;
	    src++;
	} else {
	    panic("ParseTokens encountered unknown character");
	}
    }
    if (parsePtr->numTokens == originalTokens) {
	/*
	 * There was nothing in this range of text.  Add an empty token
	 * for the empty range, so that there is always at least one
	 * token added.
	 */








	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->size = 0;
	parsePtr->numTokens++;
    }
    parsePtr->term = src;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeParse --
 *
 *	This procedure is invoked to free any dynamic storage that may
 *	have been allocated by a previous call to Tcl_ParseCommand.







<
<
<
<
<
<
<
<
<
|
<
|
<
<
<
|
|
|
|
>
>
|


|
<
<
<



















<

<
<
<



<
<
<







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
>

















|
|
>








>
|
<











|







<
<
<
<
<






|
<
|
<
<
>











|




>







|


|






>






|

















>

>
>
>
>
>
>
>
>

|










>
>
>



>

<


>

<
<
<
<
<
<
<
<
<
<



|










>
>
|
>
>
>
>
>







|







365
366
367
368
369
370
371









372

373



374
375
376
377
378
379
380
381
382
383



384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402

403



404
405
406



407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798

799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817





818
819
820
821
822
823
824

825


826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915

916
917
918
919










920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
	/*
	 * Do two additional checks: (a) make sure we're really at the
	 * end of a word (there might have been garbage left after a
	 * quoted or braced word), and (b) check for the end of the
	 * command.
	 */










	scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);

	if (scanned) {



	    src += scanned; numBytes -= scanned;
	    continue;
	}

	if (numBytes == 0) {
	    break;
	}
	if ((type & terminators) != 0) {
	    parsePtr->term = src;
	    src++; 



	    break;
	}
	if (src[-1] == '"') { 
	    if (interp != NULL) {
		Tcl_SetResult(interp, "extra characters after close-quote",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
	} else {
	    if (interp != NULL) {
		Tcl_SetResult(interp, "extra characters after close-brace",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
	}
	parsePtr->term = src;
	goto error;
    }


    parsePtr->commandSize = src - parsePtr->commandStart;



    return TCL_OK;

    error:



    Tcl_FreeParse(parsePtr);
    if (parsePtr->commandStart == NULL) {
	parsePtr->commandStart = string;
    }
    parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseWhiteSpace --
 *
 *	Scans up to numBytes bytes starting at src, consuming white
 *	space as defined by Tcl's parsing rules.  
 *
 * Results:
 *	Returns the number of bytes recognized as white space.  Records
 *	at parsePtr, information about the parse.  Records at typePtr
 *	the character type of the non-whitespace character that terminated
 *	the scan.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
int
TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
    CONST char *src;		/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated if parsing indicates
				 * an incomplete command. */
    char *typePtr;		/* Points to location to store character
				 * type of character that ends run
				 * of whitespace */
{
    register char type = TYPE_NORMAL;
    register CONST char *p = src;

    while (1) {
	while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
	    numBytes--; p++;
	}
	if (numBytes && (type & TYPE_SUBS)) {
	    if (*p != '\\') {
		break;
	    }
	    if (--numBytes == 0) {
		break;
	    }
	    if (p[1] != '\n') {
		break;
	    }
	    p+=2;
	    if (--numBytes == 0) {
		parsePtr->incomplete = 1;
		break;
	    }
	    continue;
	}
	break;
    }
    *typePtr = type;
    return (p - src);
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseHex --
 *
 *	Scans a hexadecimal number as a Tcl_UniChar value.
 *	(e.g., for parsing \x and \u escape sequences).
 *	At most numBytes bytes are scanned.
 *
 * Results:
 *	The numeric value is stored in *resultPtr.
 *	Returns the number of bytes consumed.
 *
 * Notes:
 *	Relies on the following properties of the ASCII
 *	character set, with which UTF-8 is compatible:
 *
 *	The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' 
 *	occupy consecutive code points, and '0' < 'A' < 'a'.
 *
 *----------------------------------------------------------------------
 */
int
TclParseHex(src, numBytes, resultPtr)
    CONST char *src;		/* First character to parse. */
    int numBytes;		/* Max number of byes to scan */
    Tcl_UniChar *resultPtr;	/* Points to storage provided by
				 * caller where the Tcl_UniChar
				 * resulting from the conversion is
				 * to be written. */
{
    Tcl_UniChar result = 0;
    register CONST char *p = src;

    while (numBytes--) {
	unsigned char digit = UCHAR(*p);

	if (!isxdigit(digit))
	    break;

	++p;
	result <<= 4;

	if (digit >= 'a') {
	    result |= (10 + digit - 'a');
	} else if (digit >= 'A') {
	    result |= (10 + digit - 'A');
	} else {
	    result |= (digit - '0');
	}
    }

    *resultPtr = result;
    return (p - src);
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseBackslash --
 *
 *	Scans up to numBytes bytes starting at src, consuming a
 *	backslash sequence as defined by Tcl's parsing rules.  
 *
 * Results:
 * 	Records at readPtr the number of bytes making up the backslash
 * 	sequence.  Records at dst the UTF-8 encoded equivalent of
 * 	that backslash sequence.  Returns the number of bytes written
 * 	to dst, at most TCL_UTF_MAX.  Either readPtr or dst may be
 * 	NULL, if the results are not needed, but the return value is
 * 	the same either way.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */
int
TclParseBackslash(src, numBytes, readPtr, dst)
    CONST char * src;	/* Points to the backslash character of a
			 * a backslash sequence */
    int numBytes;	/* Max number of bytes to scan */
    int *readPtr;	/* NULL, or points to storage where the
			 * number of bytes scanned should be written. */
    char *dst;		/* NULL, or points to buffer where the UTF-8
			 * encoding of the backslash sequence is to be
			 * written.  At most TCL_UTF_MAX bytes will be
			 * written there. */
{
    register CONST char *p = src+1;
    Tcl_UniChar result;
    int count;
    char buf[TCL_UTF_MAX];

    if (numBytes == 0) {
	if (readPtr != NULL) {
	    *readPtr = 0;
	}
	return 0;
    }

    if (dst == NULL) {
        dst = buf;
    }

    if (numBytes == 1) {
	/* Can only scan the backslash.  Return it. */
	result = '\\';
	count = 1;
	goto done;
    }

    count = 2;
    switch (*p) {
        /*
         * Note: in the conversions below, use absolute values (e.g.,
         * 0xa) rather than symbolic values (e.g. \n) that get converted
         * by the compiler.  It's possible that compilers on some
         * platforms will do the symbolic conversions differently, which
         * could result in non-portable Tcl scripts.
         */

        case 'a':
            result = 0x7;
            break;
        case 'b':
            result = 0x8;
            break;
        case 'f':
            result = 0xc;
            break;
        case 'n':
            result = 0xa;
            break;
        case 'r':
            result = 0xd;
            break;
        case 't':
            result = 0x9;
            break;
        case 'v':
            result = 0xb;
            break;
        case 'x':
	    count += TclParseHex(p+1, numBytes-1, &result);
	    if (count == 2) {
		/* No hexadigits -> This is just "x". */
		result = 'x';
	    } else {
		/* Keep only the last byte (2 hex digits) */
		result = (unsigned char) result;
	    }
            break;
        case 'u':
	    count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
	    if (count == 2) {
		/* No hexadigits -> This is just "u". */
		result = 'u';
	    }
            break;
        case '\n':
            count--;
            do {
                p++; count++;
            } while ((count < numBytes) && ((*p == ' ') || (*p == '\t')));
            result = ' ';
            break;
        case 0:
            result = '\\';
            count = 1;
            break;
        default:
            /*
             * Check for an octal number \oo?o?
             */
            if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
                result = (unsigned char)(*p - '0');
                p++;
                if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
			|| (UCHAR(*p) >= '8')) { 
                    break;
                }
                count = 3;
                result = (unsigned char)((result << 3) + (*p - '0'));
                p++;
                if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
			|| (UCHAR(*p) >= '8')) {
                    break;
                }
                count = 4;
                result = (unsigned char)((result << 3) + (*p - '0'));
                break;
            }
            /*
             * We have to convert here in case the user has put a
             * backslash in front of a multi-byte utf-8 character.
             * While this means nothing special, we shouldn't break up
             * a correct utf-8 character. [Bug #217987] test subst-3.2
             */
	    if (Tcl_UtfCharComplete(p, numBytes - 1)) {
	        count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
	    } else {
		char utfBytes[TCL_UTF_MAX];
		memcpy(utfBytes, p, (size_t) (numBytes - 1));
		utfBytes[numBytes - 1] = '\0';
	        count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
	    }
            break;
    }

    done:
    if (readPtr != NULL) {
        *readPtr = count;
    }
    return Tcl_UniCharToUtf((int) result, dst);
}

/*
 *----------------------------------------------------------------------
 *
 * ParseComment --
 *
 *	Scans up to numBytes bytes starting at src, consuming a
 *	Tcl comment as defined by Tcl's parsing rules.  
 *
 * Results:
 * 	Records in parsePtr information about the parse.  Returns the
 * 	number of bytes consumed.
 *
 * Side effects:
 * 	None.
 *
 *----------------------------------------------------------------------
 */
static int
ParseComment(src, numBytes, parsePtr)
    CONST char *src;		/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated if parsing indicates
				 * an incomplete command. */
{
    register CONST char *p = src;
    while (numBytes) {
	char type;
	int scanned;
	do {
	    scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
	    p += scanned; numBytes -= scanned;
	} while (numBytes && (*p == '\n') && (p++,numBytes--));
	if ((numBytes == 0) || (*p != '#')) {
	    break;
	}
	if (parsePtr->commentStart == NULL) {
	    parsePtr->commentStart = p;
	}
	while (numBytes) {
	    if (*p == '\\') {
		scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
		if (scanned) {
		    p += scanned; numBytes -= scanned;
		} else {
		    /*
		     * General backslash substitution in comments isn't
		     * part of the formal spec, but test parse-15.47
		     * and history indicate that it has been the de facto
		     * rule.  Don't change it now.
		     */
		    TclParseBackslash(p, numBytes, &scanned, NULL);
		    p += scanned; numBytes -= scanned;
		}
	    } else {
		p++; numBytes--;
		if (p[-1] == '\n') {
		    break;
		}
	    }
	}
	parsePtr->commentSize = p - parsePtr->commentStart;
    }
    return (p - src);
}

/*
 *----------------------------------------------------------------------
 *
 * ParseTokens --
 *
 *	This procedure forms the heart of the Tcl parser.  It parses one
 *	or more tokens from a string, up to a termination point
 *	specified by the caller.  This procedure is used to parse
 *	unquoted command words (those not in quotes or braces), words in
 *	quotes, and array indices for variables.  No more than numBytes
 *	bytes will be scanned.
 *
 * Results:
 *	Tokens are added to parsePtr and parsePtr->term is filled in
 *	with the address of the character that terminated the parse (the
 *	first one whose CHAR_TYPE matched mask or the character at
 *	parsePtr->end).  The return value is TCL_OK if the parse
 *	completed successfully and TCL_ERROR otherwise.  If a parse
 *	error occurs and parsePtr->interp isn't NULL, then an error
 *	message is left in the interpreter's result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseTokens(src, numBytes, mask, parsePtr)
    register CONST char *src;	/* First character to parse. */
    register int numBytes;	/* Max number of bytes to scan. */
    int mask;			/* Specifies when to stop parsing.  The
				 * parse stops at the first unquoted
				 * character whose CHAR_TYPE contains
				 * any of the bits in mask. */
    Tcl_Parse *parsePtr;	/* Information about parse in progress.
				 * Updated with additional tokens and
				 * termination information. */
{
    char type; 
    int originalTokens, varToken;

    Tcl_Token *tokenPtr;
    Tcl_Parse nested;

    /*
     * Each iteration through the following loop adds one token of
     * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
     * TCL_TOKEN_VARIABLE to parsePtr.  For TCL_TOKEN_VARIABLE tokens,
     * additional tokens are added for the parsed variable name.
     */

    originalTokens = parsePtr->numTokens;
    while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;






	if ((type & TYPE_SUBS) == 0) {
	    /*
	     * This is a simple range of characters.  Scan to find the end
	     * of the range.
	     */

	    while ((++src, --numBytes) 

		    && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {


		/* empty loop */
	    }
	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '$') {
	    /*
	     * This is a variable reference.  Call Tcl_ParseVarName to do
	     * all the dirty work of parsing the name.
	     */

	    varToken = parsePtr->numTokens;
	    if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
		    parsePtr, 1) != TCL_OK) {
		return TCL_ERROR;
	    }
	    src += parsePtr->tokenPtr[varToken].size;
	    numBytes -= parsePtr->tokenPtr[varToken].size;
	} else if (*src == '[') {
	    /*
	     * Command substitution.  Call Tcl_ParseCommand recursively
	     * (and repeatedly) to parse the nested command(s), then
	     * throw away the parse information.
	     */

	    src++; numBytes--;
	    while (1) {
		if (Tcl_ParseCommand(parsePtr->interp, src,
			numBytes, 1, &nested) != TCL_OK) {
		    parsePtr->errorType = nested.errorType;
		    parsePtr->term = nested.term;
		    parsePtr->incomplete = nested.incomplete;
		    return TCL_ERROR;
		}
		src = nested.commandStart + nested.commandSize;
		numBytes = parsePtr->end - src;
		if (nested.tokenPtr != nested.staticTokens) {
		    ckfree((char *) nested.tokenPtr);
		}
		if ((*nested.term == ']') && !nested.incomplete) {
		    break;
		}
		if (numBytes == 0) {
		    if (parsePtr->interp != NULL) {
			Tcl_SetResult(parsePtr->interp,
			    "missing close-bracket", TCL_STATIC);
		    }
		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
		    parsePtr->term = tokenPtr->start;
		    parsePtr->incomplete = 1;
		    return TCL_ERROR;
		}
	    }
	    tokenPtr->type = TCL_TOKEN_COMMAND;
	    tokenPtr->size = src - tokenPtr->start;
	    parsePtr->numTokens++;
	} else if (*src == '\\') {
	    /*
	     * Backslash substitution.
	     */
	    TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);

	    if (tokenPtr->size == 1) {
		/* Just a backslash, due to end of string */
		tokenPtr->type = TCL_TOKEN_TEXT;
		parsePtr->numTokens++;
		src++; numBytes--;
		continue;
	    }

	    if (src[1] == '\n') {
		if (numBytes == 2) {
		    parsePtr->incomplete = 1;
		}

		/*
		 * Note: backslash-newline is special in that it is
		 * treated the same as a space character would be.  This
		 * means that it could terminate the token.
		 */

		if (mask & TYPE_SPACE) {
		    if (parsePtr->numTokens == originalTokens) {
			goto finishToken;
		    }
		    break;
		}
	    }

	    tokenPtr->type = TCL_TOKEN_BS;

	    parsePtr->numTokens++;
	    src += tokenPtr->size;
	    numBytes -= tokenPtr->size;
	} else if (*src == 0) {










	    tokenPtr->type = TCL_TOKEN_TEXT;
	    tokenPtr->size = 1;
	    parsePtr->numTokens++;
	    src++; numBytes--;
	} else {
	    panic("ParseTokens encountered unknown character");
	}
    }
    if (parsePtr->numTokens == originalTokens) {
	/*
	 * There was nothing in this range of text.  Add an empty token
	 * for the empty range, so that there is always at least one
	 * token added.
	 */
	if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	    TclExpandTokenArray(parsePtr);
	}
	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	finishToken:
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->size = 0;
	parsePtr->numTokens++;
    }
    parsePtr->term = src;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FreeParse --
 *
 *	This procedure is invoked to free any dynamic storage that may
 *	have been allocated by a previous call to Tcl_ParseCommand.
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
				 * previous call to Tcl_ParseCommand. */
{
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
	parsePtr->tokenPtr = parsePtr->staticTokens;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandTokenArray --
 *
 *	This procedure is invoked when the current space for tokens in
 *	a Tcl_Parse structure fills up; it allocates memory to grow the







|







971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
				 * previous call to Tcl_ParseCommand. */
{
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
	parsePtr->tokenPtr = parsePtr->staticTokens;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclExpandTokenArray --
 *
 *	This procedure is invoked when the current space for tokens in
 *	a Tcl_Parse structure fills up; it allocates memory to grow the
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756

757
758
759
760
761
762
763
	    (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.

 *
 * 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







|






|
>







1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
	    (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    parsePtr->tokenPtr = newPtr;
    parsePtr->tokensAvailable = newCount;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVarName --
 *
 *	Given a string starting with a $ sign, parse off a variable
 *	name and return information about the parse.  No more than
 *	numBytes bytes will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed
 *	successfully and TCL_ERROR otherwise.  If an error occurs and
 *	interp isn't NULL then an error message is left in its result. 
 *	On a successful return, tokenPtr and numTokens fields of
 *	parsePtr are filled in with information about the variable name
776
777
778
779
780
781
782
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
 */

int
Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    char *string;		/* String containing variable name.  First
				 * character must be "$". */
    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;
    char *end, *src;
    unsigned char c;
    int varIndex, offset;
    Tcl_UniChar ch;
    unsigned array;




    if (numBytes >= 0) {
	end = string + numBytes;
    } else {
	end = string + strlen(string);
    }

    if (!append) {
	parsePtr->numWords = 0;
	parsePtr->tokenPtr = parsePtr->staticTokens;
	parsePtr->numTokens = 0;
	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	parsePtr->string = string;
	parsePtr->end = end;
	parsePtr->interp = interp;
	parsePtr->errorType = TCL_PARSE_SUCCESS;
	parsePtr->incomplete = 0;
    }

    /*
     * Generate one token for the variable, an additional token for the







|

|










|





>
>
>
|
<
<
|








|







1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073


1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
 */

int
Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* String containing variable name.  First
				 * character must be "$". */
    register int numBytes;	/* Total number of bytes in string.  If < 0,
				 * the string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill in with information
				 * about the variable name. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means ignore
				 * existing tokens in parsePtr and reinitialize
				 * it. */
{
    Tcl_Token *tokenPtr;
    register CONST char *src;
    unsigned char c;
    int varIndex, offset;
    Tcl_UniChar ch;
    unsigned array;

    if ((numBytes == 0) || (string == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {


	numBytes = strlen(string);
    }

    if (!append) {
	parsePtr->numWords = 0;
	parsePtr->tokenPtr = parsePtr->staticTokens;
	parsePtr->numTokens = 0;
	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	parsePtr->string = string;
	parsePtr->end = (string + numBytes);
	parsePtr->interp = interp;
	parsePtr->errorType = TCL_PARSE_SUCCESS;
	parsePtr->incomplete = 0;
    }

    /*
     * Generate one token for the variable, an additional token for the
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
    }
    tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
    tokenPtr->type = TCL_TOKEN_VARIABLE;
    tokenPtr->start = src;
    varIndex = parsePtr->numTokens;
    parsePtr->numTokens++;
    tokenPtr++;
    src++;
    if (src >= end) {
	goto justADollarSign;
    }
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src;
    tokenPtr->numComponents = 0;

    /*







|
|







1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
    }
    tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
    tokenPtr->type = TCL_TOKEN_VARIABLE;
    tokenPtr->start = src;
    varIndex = parsePtr->numTokens;
    parsePtr->numTokens++;
    tokenPtr++;
    src++; numBytes--;
    if (numBytes == 0) {
	goto justADollarSign;
    }
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src;
    tokenPtr->numComponents = 0;

    /*
855
856
857
858
859
860
861
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
     *    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++;
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	while (1) {


	    if (src == end) {
		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;
	    }
	    if (*src == '}') {
		break;
	    }
	    src++;
	}
	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 (src != end) {

	    offset = Tcl_UtfToUniChar(src, &ch);






	    c = UCHAR(ch);
	    if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
		src += offset;
		continue;
	    }
	    if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) {
		src += 2;
		while ((src != end) && (*src == ':')) {
		    src += 1;
		}
		continue;
	    }
	    break;
	}

	/*
	 * Support for empty array names here.
	 */
	array = ((src != end) && (*src == '('));
	tokenPtr->size = src - tokenPtr->start;
	if (tokenPtr->size == 0 && !array) {
	    goto justADollarSign;
	}
	parsePtr->numTokens++;
	if (array) {
	    /*
	     * This is a reference to an array element.  Call
	     * ParseTokens recursively to parse the element name,
	     * since it could contain any number of substitutions.
	     */

	    if (ParseTokens(src+1, TYPE_CLOSE_PAREN, parsePtr)
		    != TCL_OK) {
		goto error;
	    }
	    if ((parsePtr->term == end) || (*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;







|



>
|
>
>
|
|
<
|

|
|
|
|
|
<
<
<
<
<









|
>
|
>
>
>
>
>
>


|


|
|
|
|









|

|










|



|
>







1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140

1141
1142
1143
1144
1145
1146
1147





1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
     *    between parentheses is the array element name.
     * 3. The $ sign is followed by something that isn't a letter,
     *    digit, or underscore:  in this case, there is no variable
     *    name and the token is just "$".
     */

    if (*src == '{') {
	src++; numBytes--;
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;

	while (numBytes && (*src != '}')) {
	    numBytes--; src++;
	}
	if (numBytes == 0) {
	    if (interp != NULL) {

		Tcl_SetResult(interp, "missing close-brace for variable name",
			TCL_STATIC);
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
	    parsePtr->term = tokenPtr->start-1;
	    parsePtr->incomplete = 1;
	    goto error;





	}
	tokenPtr->size = src - tokenPtr->start;
	tokenPtr[-1].size = src - tokenPtr[-1].start;
	parsePtr->numTokens++;
	src++;
    } else {
	tokenPtr->type = TCL_TOKEN_TEXT;
	tokenPtr->start = src;
	tokenPtr->numComponents = 0;
	while (numBytes) {
	    if (Tcl_UtfCharComplete(src, numBytes)) {
	        offset = Tcl_UtfToUniChar(src, &ch);
	    } else {
		char utfBytes[TCL_UTF_MAX];
		memcpy(utfBytes, src, (size_t) numBytes);
		utfBytes[numBytes] = '\0';
	        offset = Tcl_UtfToUniChar(utfBytes, &ch);
	    }
	    c = UCHAR(ch);
	    if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
		src += offset;  numBytes -= offset;
		continue;
	    }
	    if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
		src += 2; numBytes -= 2;
		while (numBytes && (*src == ':')) {
		    src++; numBytes--; 
		}
		continue;
	    }
	    break;
	}

	/*
	 * Support for empty array names here.
	 */
	array = (numBytes && (*src == '('));
	tokenPtr->size = src - tokenPtr->start;
	if ((tokenPtr->size == 0) && !array) {
	    goto justADollarSign;
	}
	parsePtr->numTokens++;
	if (array) {
	    /*
	     * This is a reference to an array element.  Call
	     * ParseTokens recursively to parse the element name,
	     * since it could contain any number of substitutions.
	     */

	    if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
		    != TCL_OK) {
		goto error;
	    }
	    if ((parsePtr->term == (src + numBytes)) 
		    || (*parsePtr->term != ')')) { 
		if (parsePtr->interp != NULL) {
		    Tcl_SetResult(parsePtr->interp, "missing )",
			    TCL_STATIC);
		}
		parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
		parsePtr->term = src;
		parsePtr->incomplete = 1;
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
    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.







|







1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
    tokenPtr->numComponents = 0;
    return TCL_OK;

    error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseVar --
 *
 *	Given a string starting with a $ sign, parse off a variable
 *	name and return its value.
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ParseVar(interp, string, termPtr)
    Tcl_Interp *interp;			/* Context for looking up variable. */
    register char *string;		/* String containing variable name.
					 * First character must be "$". */
    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;







|

|







1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_ParseVar(interp, string, termPtr)
    Tcl_Interp *interp;			/* Context for looking up variable. */
    register CONST char *string;	/* String containing variable name.
					 * First character must be "$". */
    CONST char **termPtr;		/* If non-NULL, points to word to fill
					 * in with character just after last
					 * one in the variable specifier. */

{
    Tcl_Parse parse;
    register Tcl_Obj *objPtr;
    int code;
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046

1047
1048
1049
1050
1051
1052
1053

    if (!Tcl_IsShared(objPtr)) {
	Tcl_IncrRefCount(objPtr);
    }
    Tcl_ResetResult(interp);
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseBraces --
 *
 *	Given a string in braces such as a Tcl command argument or a string
 *	value in a Tcl expression, this procedure parses the string and
 *	returns information about the parse.

 *
 * 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







|







|
>







1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328

    if (!Tcl_IsShared(objPtr)) {
	Tcl_IncrRefCount(objPtr);
    }
    Tcl_ResetResult(interp);
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseBraces --
 *
 *	Given a string in braces such as a Tcl command argument or a string
 *	value in a Tcl expression, this procedure parses the string and
 *	returns information about the parse.  No more than numBytes bytes
 *	will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the string was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
 *	an error message is left in its result. On a successful return,
 *	tokenPtr and numTokens fields of parsePtr are filled in with
 *	information about the string that was parsed. Other fields in
1065
1066
1067
1068
1069
1070
1071
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
 */

int
Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    char *string;		/* String containing the string in braces.
				 * The first character must be '{'. */
    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. */
    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. */

{
    char utfBytes[TCL_UTF_MAX];	/* For result of backslash substitution. */
    Tcl_Token *tokenPtr;
    register char *src, *end;
    int startIndex, level, length;

    if ((numBytes >= 0) || (string == NULL)) {


	end = string + numBytes;
    } else {
	end = string + strlen(string);
    }
    
    if (!append) {
	parsePtr->numWords = 0;
	parsePtr->tokenPtr = parsePtr->staticTokens;
	parsePtr->numTokens = 0;
	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	parsePtr->string = string;
	parsePtr->end = end;
	parsePtr->interp = interp;
	parsePtr->errorType = TCL_PARSE_SUCCESS;
    }

    src = string+1;
    startIndex = parsePtr->numTokens;

    if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    tokenPtr = &parsePtr->tokenPtr[startIndex];
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src;
    tokenPtr->numComponents = 0;
    level = 1;
    while (1) {

	while (CHAR_TYPE(*src) == TYPE_NORMAL) {





	    src++;









	}
	if (*src == '}') {

	    level--;




















	    if (level == 0) {


		break;
	    }

	    src++;




	} else if (*src == '{') {

	    level++;



	    src++;












	} else if (*src == '\\') {












	    Tcl_UtfBackslash(src, &length, utfBytes);
	    if (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 ((src + 2) == end) {
		    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;

		tokenPtr++;
		tokenPtr->type = TCL_TOKEN_TEXT;
		tokenPtr->start = src;
		tokenPtr->numComponents = 0;
	    } else {
		src += length;
	    }
	} else if (src == end) {
	    int openBrace;

	    if (interp != NULL) {
		Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
	    }
	    /*
	     *  Search 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 preceeded by a '<whitspace>#' on 
	     *  the same line.
	     */
	    openBrace = 0;
	    while (src > string ) {
		switch (*src) {
		    case '{': 
			openBrace = 1; 
			break;
		    case '\n':
			openBrace = 0; 
			break;
		    case '#':
			if ((openBrace == 1) && (isspace(UCHAR(src[-1])))) {
			    if (interp != NULL) {
				Tcl_AppendResult(interp,
					": possible unbalanced brace in comment",
					(char *) NULL);
			    }
			    openBrace = -1;
			    break;
			}
			break;
		}
		if (openBrace == -1) {
		    break;
		}
		src--;
	    }
	    parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
	    parsePtr->term = string;
	    parsePtr->incomplete = 1;
	    goto error;
	} else {
	    src++;
	}
    }

    /*
     * 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;

    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 procedure parses the
 *	string and returns information about the parse.

 *
 * 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







|

|









|





<

|


|
>
>
|
<
|

|






|




|







|



>
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
>
|
>
>
>
>
|
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
>
|
|
|
|
|
|
<
<
<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
|
<
<
|
<
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







|
>







1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364

1365
1366
1367
1368
1369
1370
1371
1372

1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516



1517


1518












1519









1520


1521

1522


1523




































1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
 */

int
Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* String containing the string in braces.
				 * The first character must be '{'. */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to
				 * the first null character. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information
				 * about the string. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means
				 * ignore existing tokens in parsePtr and
				 * reinitialize it. */
    CONST char **termPtr;	/* If non-NULL, points to word in which to
				 * store a pointer to the character just
				 * after the terminating '}' if the parse
				 * was successful. */

{

    Tcl_Token *tokenPtr;
    register CONST char *src;
    int startIndex, level, length;

    if ((numBytes == 0) || (string == NULL)) {
	return TCL_ERROR;
    }
    if (numBytes < 0) {

	numBytes = strlen(string);
    }

    if (!append) {
	parsePtr->numWords = 0;
	parsePtr->tokenPtr = parsePtr->staticTokens;
	parsePtr->numTokens = 0;
	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	parsePtr->string = string;
	parsePtr->end = (string + numBytes);
	parsePtr->interp = interp;
	parsePtr->errorType = TCL_PARSE_SUCCESS;
    }

    src = string;
    startIndex = parsePtr->numTokens;

    if (parsePtr->numTokens == parsePtr->tokensAvailable) {
	TclExpandTokenArray(parsePtr);
    }
    tokenPtr = &parsePtr->tokenPtr[startIndex];
    tokenPtr->type = TCL_TOKEN_TEXT;
    tokenPtr->start = src+1;
    tokenPtr->numComponents = 0;
    level = 1;
    while (1) {
	while (++src, --numBytes) {
	    if (CHAR_TYPE(*src) != TYPE_NORMAL) {
		break;
	    }
	}
	if (numBytes == 0) {
	    register int openBrace = 0;

	    parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
	    parsePtr->term = string;
	    parsePtr->incomplete = 1;
	    if (interp == NULL) {
		/*
		 * Skip straight to the exit code since we have no
		 * interpreter to put error message in.
		 */
		goto error;
	    }

	    Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);

	    /*
	     *  Guess if the problem is due to comments by searching
	     *  the source string for a possible open brace within the
	     *  context of a comment.  Since we aren't performing a
	     *  full Tcl parse, just look for an open brace preceded
	     *  by a '<whitespace>#' on the same line.
	     */

	    for (; src > string; src--) {
		switch (*src) {
		    case '{':
			openBrace = 1;
			break;
		    case '\n':
			openBrace = 0;
			break;
		    case '#' :
			if (openBrace && (isspace(UCHAR(src[-1])))) {
			    Tcl_AppendResult(interp,
				    ": possible unbalanced brace in comment",
				    (char *) NULL);
			    goto error;
			}
			break;
		}
	    }

	    error:
	    Tcl_FreeParse(parsePtr);
	    return TCL_ERROR;
	}
	switch (*src) {
	    case '{':
		level++;
		break;
	    case '}':
		if (--level == 0) {

		    /*
		     * Decide if we need to finish emitting a
		     * partially-finished token.  There are 3 cases:
		     *     {abc \newline xyz} or {xyz}
		     *		- finish emitting "xyz" token
		     *     {abc \newline}
		     *		- don't emit token after \newline
		     *     {}	- finish emitting zero-sized token
		     *
		     * The last case ensures that there is a token
		     * (even if empty) that describes the braced string.
		     */
    
		    if ((src != tokenPtr->start)
			    || (parsePtr->numTokens == startIndex)) {
			tokenPtr->size = (src - tokenPtr->start);
			parsePtr->numTokens++;
		    }
		    if (termPtr != NULL) {
			*termPtr = src+1;
		    }
		    return TCL_OK;
		}
		break;
	    case '\\':
		TclParseBackslash(src, numBytes, &length, NULL);
		if ((length > 1) && (src[1] == '\n')) {
		    /*
		     * A backslash-newline sequence must be collapsed, even
		     * inside braces, so we have to split the word into
		     * multiple tokens so that the backslash-newline can be
		     * represented explicitly.
		     */
		
		    if (numBytes == 2) {
			parsePtr->incomplete = 1;
		    }
		    tokenPtr->size = (src - tokenPtr->start);
		    if (tokenPtr->size != 0) {
			parsePtr->numTokens++;
		    }
		    if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
			TclExpandTokenArray(parsePtr);
		    }
		    tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
		    tokenPtr->type = TCL_TOKEN_BS;
		    tokenPtr->start = src;
		    tokenPtr->size = length;
		    tokenPtr->numComponents = 0;
		    parsePtr->numTokens++;
		
		    src += length - 1;
		    numBytes -= length - 1;
		    tokenPtr++;
		    tokenPtr->type = TCL_TOKEN_TEXT;
		    tokenPtr->start = src + 1;
		    tokenPtr->numComponents = 0;
		} else {
		    src += length - 1;



		    numBytes -= length - 1;


		}












		break;









	}


    }

}







































/*
 *----------------------------------------------------------------------
 *
 * Tcl_ParseQuotedString --
 *
 *	Given a double-quoted string such as a quoted Tcl command argument
 *	or a quoted value in a Tcl expression, this procedure parses the
 *	string and returns information about the parse.  No more than
 *	numBytes bytes will be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the string was parsed successfully and
 *	TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
 *	an error message is left in its result. On a successful return,
 *	tokenPtr and numTokens fields of parsePtr are filled in with
 *	information about the string that was parsed. Other fields in
1270
1271
1272
1273
1274
1275
1276
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
 */

int
Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    char *string;		/* String containing the quoted string. 
				 * The first character must be '"'. */
    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. */
    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. */
{
    char *end;

    
    if ((numBytes >= 0) || (string == NULL)) {
	end = string + numBytes;
    } else {
	end = string + strlen(string);
    }
    
    if (!append) {
	parsePtr->numWords = 0;
	parsePtr->tokenPtr = parsePtr->staticTokens;
	parsePtr->numTokens = 0;
	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	parsePtr->string = string;
	parsePtr->end = end;
	parsePtr->interp = interp;
	parsePtr->errorType = TCL_PARSE_SUCCESS;
    }
    
    if (ParseTokens(string+1, TYPE_QUOTE, parsePtr) != TCL_OK) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (interp != NULL) {
	    Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = string;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {
	*termPtr = (parsePtr->term + 1);
    }
    return TCL_OK;

    error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * CommandComplete --
 *
 *	This procedure is shared by TclCommandComplete and
 *	Tcl_ObjCommandcoComplete; it does all the real work of seeing







|

|









|




|
>
|
<
|
<
|

|






|




|




















|







1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577

1578

1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
 */

int
Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting;
				 * if NULL, then no error message is
				 * provided. */
    CONST char *string;		/* String containing the quoted string. 
				 * The first character must be '"'. */
    register int numBytes;	/* Total number of bytes in string. If < 0,
				 * the string consists of all bytes up to
				 * the first null character. */
    register Tcl_Parse *parsePtr;
    				/* Structure to fill in with information
				 * about the string. */
    int append;			/* Non-zero means append tokens to existing
				 * information in parsePtr; zero means
				 * ignore existing tokens in parsePtr and
				 * reinitialize it. */
    CONST char **termPtr;	/* If non-NULL, points to word in which to
				 * store a pointer to the character just
				 * after the quoted string's terminating
				 * close-quote if the parse succeeds. */
{
    if ((numBytes == 0) || (string == NULL)) {
	return TCL_ERROR;
    }

    if (numBytes < 0) {

	numBytes = strlen(string);
    }

    if (!append) {
	parsePtr->numWords = 0;
	parsePtr->tokenPtr = parsePtr->staticTokens;
	parsePtr->numTokens = 0;
	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
	parsePtr->string = string;
	parsePtr->end = (string + numBytes);
	parsePtr->interp = interp;
	parsePtr->errorType = TCL_PARSE_SUCCESS;
    }
    
    if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
	goto error;
    }
    if (*parsePtr->term != '"') {
	if (interp != NULL) {
	    Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
	}
	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
	parsePtr->term = string;
	parsePtr->incomplete = 1;
	goto error;
    }
    if (termPtr != NULL) {
	*termPtr = (parsePtr->term + 1);
    }
    return TCL_OK;

    error:
    Tcl_FreeParse(parsePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * CommandComplete --
 *
 *	This procedure is shared by TclCommandComplete and
 *	Tcl_ObjCommandcoComplete; it does all the real work of seeing
1349
1350
1351
1352
1353
1354
1355
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
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(script, length)
    char *script;			/* Script to check. */
    int length;				/* Number of bytes in script. */
{
    Tcl_Parse parse;
    char *p, *end;
    int result;

    p = script;
    end = p + length;
    while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
	    == TCL_OK) {
	p = parse.commandStart + parse.commandSize;
	if (*p == 0) {
	    break;
	}
	Tcl_FreeParse(&parse);
    }
    if (parse.incomplete) {
	result = 0;
    } else {
	result = 1;
    }
    Tcl_FreeParse(&parse);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandComplete --
 *
 *	Given a partial or complete Tcl script, this procedure
 *	determines whether the script is complete in the sense







|
|
|


|



|
















|







1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
CommandComplete(script, numBytes)
    CONST char *script;			/* Script to check. */
    int numBytes;			/* Number of bytes in script. */
{
    Tcl_Parse parse;
    CONST char *p, *end;
    int result;

    p = script;
    end = p + numBytes;
    while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
	    == TCL_OK) {
	p = parse.commandStart + parse.commandSize;
	if (*p == 0) {
	    break;
	}
	Tcl_FreeParse(&parse);
    }
    if (parse.incomplete) {
	result = 0;
    } else {
	result = 1;
    }
    Tcl_FreeParse(&parse);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandComplete --
 *
 *	Given a partial or complete Tcl script, this procedure
 *	determines whether the script is complete in the sense
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CommandComplete(script)
    char *script;			/* Script to check. */
{
    return CommandComplete(script, (int) strlen(script));
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjCommandComplete --
 *
 *	Given a partial or complete Tcl command in a Tcl object, this
 *	procedure determines whether the command is complete in the sense of







|



|







1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_CommandComplete(script)
    CONST char *script;			/* Script to check. */
{
    return CommandComplete(script, (int) strlen(script));
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjCommandComplete --
 *
 *	Given a partial or complete Tcl command in a Tcl object, this
 *	procedure determines whether the command is complete in the sense of
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
 */

int
TclObjCommandComplete(objPtr)
    Tcl_Obj *objPtr;			/* Points to object holding script
					 * to check. */
{
    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.







|





|







1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
 */

int
TclObjCommandComplete(objPtr)
    Tcl_Obj *objPtr;			/* Points to object holding script
					 * to check. */
{
    CONST char *script;
    int length;

    script = Tcl_GetStringFromObj(objPtr, &length);
    return CommandComplete(script, length);
}

/*
 *----------------------------------------------------------------------
 *
 * TclIsLocalScalar --
 *
 *	Check to see if a given string is a legal scalar variable
 *	name with no namespace qualifiers or substitutions.
Changes to generic/tclParseExpr.c.
1
2
3
4
5
6
7
8
9
10

11
12
13
14
15
16
17
18
19
20
21
22
/* 
 * tclParseExpr.c --
 *
 *	This file contains procedures that parse Tcl expressions. They
 *	do so in a general-purpose fashion that can be used for many
 *	different purposes, including compilation, direct execution,
 *	code analysis, etc.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.

 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParseExpr.c,v 1.9.2.2 2002/06/10 05:33:12 wolfsuit Exp $
 */

#include "tclInt.h"

/*
 * The stuff below is a bit of a hack so that this file can be used in
 * environments that include no UNIX, i.e. no errno: just arrange to use










>




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
/* 
 * tclParseExpr.c --
 *
 *	This file contains procedures that parse Tcl expressions. They
 *	do so in a general-purpose fashion that can be used for many
 *	different purposes, including compilation, direct execution,
 *	code analysis, etc.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclParseExpr.c,v 1.9.2.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"

/*
 * The stuff below is a bit of a hack so that this file can be used in
 * environments that include no UNIX, i.e. no errno: just arrange to use
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

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. */
    char *start;		/* First character in lexeme. */
    int size;			/* Number of bytes in lexeme. */
    char *next;			/* Position of the next character to be
				 * scanned in the expression string. */
    char *prevEnd;		/* Points to the character just after the
				 * last one in the previous lexeme. Used to
				 * compute size of subexpression tokens. */
    char *originalExpr;		/* Points to the start of the expression
				 * originally passed to Tcl_ParseExpr. */
    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.
 *







|

|

|


|

|







52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

typedef struct ParseInfo {
    Tcl_Parse *parsePtr;	/* Points to structure to fill in with
				 * information about the expression. */
    int lexeme;			/* Type of last lexeme scanned in expr.
				 * See below for definitions. Corresponds to
				 * size characters beginning at start. */
    CONST char *start;		/* First character in lexeme. */
    int size;			/* Number of bytes in lexeme. */
    CONST char *next;		/* Position of the next character to be
				 * scanned in the expression string. */
    CONST char *prevEnd;	/* Points to the character just after the
				 * last one in the previous lexeme. Used to
				 * compute size of subexpression tokens. */
    CONST char *originalExpr;	/* Points to the start of the expression
				 * originally passed to Tcl_ParseExpr. */
    CONST char *lastChar;	/* Points just after last byte of expr. */
} ParseInfo;

/*
 * Definitions of the different lexemes that appear in expressions. The
 * order of these must match the corresponding entries in the
 * operatorStrings array below.
 *
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159


160
161
162
163
164
165
166
167
168
169
170
171
172
173

/*
 * Declarations for local procedures to this file:
 */

static int		GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
static void		LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr,
				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		ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static void		PrependSubExprTokens _ANSI_ARGS_((char *op,
				int opBytes, char *src, int srcBytes,
				int firstIndex, ParseInfo *infoPtr));

/*
 * Macro used to debug the execution of the recursive descent parser used
 * to parse expressions.
 */








|








>
>





|
|







145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

/*
 * Declarations for local procedures to this file:
 */

static int		GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
static void		LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr,
				CONST char *extraInfo));
static int		ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string,
				CONST char *end));
static int		ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int		ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static void		PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
				int opBytes, CONST char *src, int srcBytes,
				int firstIndex, ParseInfo *infoPtr));

/*
 * Macro used to debug the execution of the recursive descent parser used
 * to parse expressions.
 */

186
187
188
189
190
191
192
193

194
195
196
197
198
199
200
 *----------------------------------------------------------------------
 *
 * Tcl_ParseExpr --
 *
 *	Given a string, this procedure parses the first Tcl expression
 *	in the string and returns information about the structure of
 *	the expression. This procedure is the top-level interface to the
 *	the expression parsing module.

 *
 * 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.







|
>







189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
 *----------------------------------------------------------------------
 *
 * Tcl_ParseExpr --
 *
 *	Given a string, this procedure parses the first Tcl expression
 *	in the string and returns information about the structure of
 *	the expression. This procedure is the top-level interface to the
 *	the expression parsing module.  No more that numBytes bytes will
 *	be scanned.
 *
 * Results:
 *	The return value is TCL_OK if the command was parsed successfully
 *	and TCL_ERROR otherwise. If an error occurs and interp isn't NULL
 *	then an error message is left in its result. On a successful return,
 *	parsePtr is filled in with information about the expression that 
 *	was parsed.
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    char *string;		/* The source string to parse. */
    int numBytes;		/* Number of bytes in string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill with information about
				 * the parsed expression; any previous
				 * information in the structure is
				 * ignored. */
{
    ParseInfo info;
    int code;
    char savedChar;

    if (numBytes < 0) {
	numBytes = (string? strlen(string) : 0);
    }
#ifdef TCL_COMPILE_DEBUG
    if (traceParseExpr) {
	fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",







|










<







212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229

230
231
232
233
234
235
236
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    CONST char *string;		/* The source string to parse. */
    int numBytes;		/* Number of bytes in string. If < 0, the
				 * string consists of all bytes up to the
				 * first null character. */
    Tcl_Parse *parsePtr;	/* Structure to fill with information about
				 * the parsed expression; any previous
				 * information in the structure is
				 * ignored. */
{
    ParseInfo info;
    int code;


    if (numBytes < 0) {
	numBytes = (string? strlen(string) : 0);
    }
#ifdef TCL_COMPILE_DEBUG
    if (traceParseExpr) {
	fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
    parsePtr->string = string;
    parsePtr->end = (string + numBytes);
    parsePtr->interp = interp;
    parsePtr->term = string;
    parsePtr->incomplete = 0;

    /*
     * Temporarily overwrite the character just after the end of the
     * string with a 0 byte.  This acts as a sentinel and reduces the
     * number of places where we have to check for the end of the
     * input string.  The original value of the byte is restored at
     * the end of the parse.
     */

    savedChar = string[numBytes];
    string[numBytes] = 0;

    /*
     * Initialize the ParseInfo structure that holds state while parsing
     * the expression.
     */

    info.parsePtr = parsePtr;
    info.lexeme = UNKNOWN;







<
<
<
<
<
<
<
<
<
<
<







248
249
250
251
252
253
254











255
256
257
258
259
260
261
    parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
    parsePtr->string = string;
    parsePtr->end = (string + numBytes);
    parsePtr->interp = interp;
    parsePtr->term = string;
    parsePtr->incomplete = 0;












    /*
     * Initialize the ParseInfo structure that holds state while parsing
     * the expression.
     */

    info.parsePtr = parsePtr;
    info.lexeme = UNKNOWN;
286
287
288
289
290
291
292
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
    if (code != TCL_OK) {
	goto error;
    }
    if (info.lexeme != END) {
	LogSyntaxError(&info, "extra tokens at end of expression");
	goto error;
    }
    string[numBytes] = (char) savedChar;
    return TCL_OK;
    
    error:
    string[numBytes] = (char) savedChar;
    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseCondExpr --
 *
 *	This procedure parses a Tcl conditional expression:
 *	condExpr ::= lorExpr ['?' condExpr ':' condExpr]
 *
 *	Note that this is the topmost recursive-descent parsing routine used
 *	by TclParseExpr to parse expressions. This avoids an extra procedure
 *	call since such a procedure would only return the result of calling
 *	ParseCondExpr. Other recursive-descent procedures that need to parse
 *	complete expressions also call ParseCondExpr.
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result







<



<















|







278
279
280
281
282
283
284

285
286
287

288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
    if (code != TCL_OK) {
	goto error;
    }
    if (info.lexeme != END) {
	LogSyntaxError(&info, "extra tokens at end of expression");
	goto error;
    }

    return TCL_OK;
    
    error:

    if (parsePtr->tokenPtr != parsePtr->staticTokens) {
	ckfree((char *) parsePtr->tokenPtr);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseCondExpr --
 *
 *	This procedure parses a Tcl conditional expression:
 *	condExpr ::= lorExpr ['?' condExpr ':' condExpr]
 *
 *	Note that this is the topmost recursive-descent parsing routine used
 *	by Tcl_ParseExpr to parse expressions. This avoids an extra procedure
 *	call since such a procedure would only return the result of calling
 *	ParseCondExpr. Other recursive-descent procedures that need to parse
 *	complete expressions also call ParseCondExpr.
 *
 * Results:
 *	The return value is TCL_OK on a successful parse and TCL_ERROR
 *	on failure. If TCL_ERROR is returned, then the interpreter's result
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
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;
    char *srcStart;
    
    HERE("condExpr", 1);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseLorExpr(infoPtr);
    if (code != TCL_OK) {







|







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
ParseCondExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
    int firstIndex, numToMove, code;
    CONST char *srcStart;
    
    HERE("condExpr", 1);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseLorExpr(infoPtr);
    if (code != TCL_OK) {
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
static int
ParseLorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    char *srcStart, *operator;
    
    HERE("lorExpr", 2);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseLandExpr(infoPtr);
    if (code != TCL_OK) {







|







435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
static int
ParseLorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;
    
    HERE("lorExpr", 2);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseLandExpr(infoPtr);
    if (code != TCL_OK) {
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
static int
ParseLandExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    char *srcStart, *operator;

    HERE("landExpr", 3);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitOrExpr(infoPtr);
    if (code != TCL_OK) {







|







495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
static int
ParseLandExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("landExpr", 3);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitOrExpr(infoPtr);
    if (code != TCL_OK) {
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
static int
ParseBitOrExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    char *srcStart, *operator;

    HERE("bitOrExpr", 4);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitXorExpr(infoPtr);
    if (code != TCL_OK) {







|







555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
static int
ParseBitOrExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitOrExpr", 4);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitXorExpr(infoPtr);
    if (code != TCL_OK) {
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
static int
ParseBitXorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    char *srcStart, *operator;

    HERE("bitXorExpr", 5);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitAndExpr(infoPtr);
    if (code != TCL_OK) {







|







616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
static int
ParseBitXorExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitXorExpr", 5);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseBitAndExpr(infoPtr);
    if (code != TCL_OK) {
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
static int
ParseBitAndExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    char *srcStart, *operator;

    HERE("bitAndExpr", 6);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseEqualityExpr(infoPtr);
    if (code != TCL_OK) {







|







677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
static int
ParseBitAndExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, code;
    CONST char *srcStart, *operator;

    HERE("bitAndExpr", 6);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseEqualityExpr(infoPtr);
    if (code != TCL_OK) {
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
static int
ParseEqualityExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    char *srcStart, *operator;

    HERE("equalityExpr", 7);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseRelationalExpr(infoPtr);
    if (code != TCL_OK) {







|







738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
static int
ParseEqualityExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("equalityExpr", 7);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseRelationalExpr(infoPtr);
    if (code != TCL_OK) {
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
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;
    char *srcStart, *operator;

    HERE("relationalExpr", 8);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseShiftExpr(infoPtr);
    if (code != TCL_OK) {







|







802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
static int
ParseRelationalExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, operatorSize, code;
    CONST char *srcStart, *operator;

    HERE("relationalExpr", 8);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseShiftExpr(infoPtr);
    if (code != TCL_OK) {
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
static int
ParseShiftExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    char *srcStart, *operator;

    HERE("shiftExpr", 9);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseAddExpr(infoPtr);
    if (code != TCL_OK) {







|







870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
static int
ParseShiftExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("shiftExpr", 9);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseAddExpr(infoPtr);
    if (code != TCL_OK) {
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
static int
ParseAddExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    char *srcStart, *operator;

    HERE("addExpr", 10);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseMultiplyExpr(infoPtr);
    if (code != TCL_OK) {







|







932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
static int
ParseAddExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("addExpr", 10);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseMultiplyExpr(infoPtr);
    if (code != TCL_OK) {
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
static int
ParseMultiplyExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    char *srcStart, *operator;

    HERE("multiplyExpr", 11);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseUnaryExpr(infoPtr);
    if (code != TCL_OK) {







|







994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
static int
ParseMultiplyExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("multiplyExpr", 11);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    code = ParseUnaryExpr(infoPtr);
    if (code != TCL_OK) {
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
static int
ParseUnaryExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    char *srcStart, *operator;

    HERE("unaryExpr", 12);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    lexeme = infoPtr->lexeme;
    if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)







|







1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
static int
ParseUnaryExpr(infoPtr)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    int firstIndex, lexeme, code;
    CONST char *srcStart, *operator;

    HERE("unaryExpr", 12);
    srcStart = infoPtr->start;
    firstIndex = parsePtr->numTokens;
    
    lexeme = infoPtr->lexeme;
    if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
    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;
    char *dollarPtr, *stringStart, *termPtr, *src;
    int lexeme, exprIndex, firstIndex, numToMove, code;

    /*
     * We simply recurse on parenthesized subexpressions.
     */

    HERE("primaryExpr", 13);







|







1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
{
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Interp *interp = parsePtr->interp;
    Tcl_Token *tokenPtr, *exprTokenPtr;
    Tcl_Parse nested;
    CONST char *dollarPtr, *stringStart, *termPtr, *src;
    int lexeme, exprIndex, firstIndex, numToMove, code;

    /*
     * We simply recurse on parenthesized subexpressions.
     */

    HERE("primaryExpr", 13);
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401

1402

1403
1404
1405

1406

1407

1408
1409
1410
1411
1412
1413
1414
	     * whether we have a function or variable name here.
	     * Alas, this makes the parser more tightly bound with the
	     * rest of the interpreter, but that is the only way to
	     * give a sensible message here.  Still, it is not too
	     * serious as this is only done when generating an error.
	     */
	    Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
	    char savedChar;
	    Tcl_HashEntry *hPtr;

	    /*
	     * Look up the name as a function name; note that this

	     * requires the expression to be in writable memory.

	     */
	    savedChar = tokenPtr->start[tokenPtr->size];
	    tokenPtr->start[tokenPtr->size] = '\0';

	    hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, tokenPtr->start);

	    tokenPtr->start[tokenPtr->size] = savedChar;


	    /*
	     * Assume that we have an attempted variable reference
	     * unless we've got a function name, as the set of
	     * potential function names is typically much smaller.
	     */
	    if (hPtr != NULL) {







|



|
>
|
>

<
<
>
|
>
|
>







1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395


1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
	     * whether we have a function or variable name here.
	     * Alas, this makes the parser more tightly bound with the
	     * rest of the interpreter, but that is the only way to
	     * give a sensible message here.  Still, it is not too
	     * serious as this is only done when generating an error.
	     */
	    Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
	    Tcl_DString functionName;
	    Tcl_HashEntry *hPtr;

	    /*
	     * Look up the name as a function name.  We need a writable
	     * copy (DString) so we can terminate it with a NULL for
	     * the benefit of Tcl_FindHashEntry which operates on
	     * NULL-terminated string keys.
	     */


	    Tcl_DStringInit(&functionName);
	    hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, 
	    	Tcl_DStringAppend(&functionName, tokenPtr->start,
		tokenPtr->size));
	    Tcl_DStringFree(&functionName);

	    /*
	     * Assume that we have an attempted variable reference
	     * unless we've got a function name, as the set of
	     * potential function names is typically much smaller.
	     */
	    if (hPtr != NULL) {
1521
1522
1523
1524
1525
1526
1527
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
 */

static int
GetLexeme(infoPtr)
    ParseInfo *infoPtr;		/* Holds state needed to parse the expr,
				 * including the resulting lexeme. */
{
    register char *src;		/* Points to current source char. */
    char *termPtr;		/* Points to char terminating a literal. */
    double doubleValue;		/* Value of a scanned double literal. */
    char c;
    int startsWithDigit, offset;
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Interp *interp = parsePtr->interp;
    Tcl_UniChar ch;

    /*
     * Record where the previous lexeme ended. Since we always read one
     * lexeme ahead during parsing, this helps us know the source length of
     * subexpression tokens.
     */

    infoPtr->prevEnd = infoPtr->next;

    /*
     * Scan over leading white space at the start of a lexeme. Note that a
     * backslash-newline is treated as a space.
     */

    src = infoPtr->next;
    c = *src;
    while (isspace(UCHAR(c)) || (c == '\\')) { /* INTL: ISO space */
	if (c == '\\') {
	    if (src[1] == '\n') {
		src += 2;
	    } else {
		break;	/* no longer white space */
	    }
	} else {
	    src++;
	}
	c = *src;
    }
    parsePtr->term = src;
    if (src >= infoPtr->lastChar) {
	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.
     */


    if ((c != '+') && (c != '-')) {
	startsWithDigit = isdigit(UCHAR(c)); /* INTL: digit */
	if (startsWithDigit && TclLooksLikeInt(src, -1)) {
	    errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
	    (void) strtoul(src, &termPtr, 0);
#else
	    (void) strtoull(src, &termPtr, 0);
#endif
	    if (errno == ERANGE) {
		if (interp != NULL) {
		    char *s = "integer value too large to represent";
		    Tcl_ResetResult(interp);
		    Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
		    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s,
			    (char *) NULL);
		}
		parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		return TCL_ERROR;
	    }
 	    if (termPtr != src) {
                /*
                 * src was the start of a valid integer, but was it
		 * a bad octal?  Stopping at a digit would cause that.


                 */
		if (isdigit(UCHAR(*termPtr))) {	/* INTL: digit. */
		    /*
		     * We only want to report an error for the number,


		     * but we may have something like "08+1"
		     */
		    if (interp != NULL) {
			while (isdigit(UCHAR(*(++termPtr)))) {} /* INTL: digit. */
			Tcl_ResetResult(interp);
			offset = termPtr - src;
			c = src[offset];
			src[offset] = 0;
			Tcl_AppendResult(interp, "\"", src,
				"\" is an invalid octal number",
				(char *) NULL);
			src[offset] = c;
		    }




		    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		    return TCL_ERROR;
		}

                infoPtr->lexeme = LITERAL;
		infoPtr->start = src;
		infoPtr->size = (termPtr - src);
                infoPtr->next = termPtr;
		parsePtr->term = termPtr;
                return TCL_OK;










	    }
	} else if (startsWithDigit || (c == '.')
	        || (c == 'n') || (c == 'N')) {
	    errno = 0;


	    doubleValue = strtod(src, &termPtr);

	    if (termPtr != src) {
		if (errno != 0) {
		    if (interp != NULL) {
			TclExprFloatError(interp, doubleValue);
		    }
		    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		    return TCL_ERROR;
		}
		
		/*
                 * src was the start of a valid double.

                 */
		
		infoPtr->lexeme = LITERAL;
		infoPtr->start = src;



		infoPtr->size = (termPtr - src);

		infoPtr->next = termPtr;
		parsePtr->term = termPtr;
		return TCL_OK;
	    }
	}
    }

    /*
     * Not an integer or double literal. Initialize the lexeme's fields







|
<
<

|













|
<



|
|
|
|
|
<
<
<
<
|
<
<
<

|












>

<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
|
|
<
<
>
>
|
<
<
|
>
>
<
<
<
<
<
<
<
<
<
<
<
<
|
>
>
>
>
|
|
|
<
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
|
<
<

>
>
|
>
|









|
>




>
>
>
|
>
|
|







1514
1515
1516
1517
1518
1519
1520
1521


1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537

1538
1539
1540
1541
1542
1543
1544
1545




1546



1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562














1563




1564
1565


1566
1567
1568


1569
1570
1571












1572
1573
1574
1575
1576
1577
1578
1579

1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596


1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
 */

static int
GetLexeme(infoPtr)
    ParseInfo *infoPtr;		/* Holds state needed to parse the expr,
				 * including the resulting lexeme. */
{
    register CONST char *src;	/* Points to current source char. */


    char c;
    int offset, length, numBytes;
    Tcl_Parse *parsePtr = infoPtr->parsePtr;
    Tcl_Interp *interp = parsePtr->interp;
    Tcl_UniChar ch;

    /*
     * Record where the previous lexeme ended. Since we always read one
     * lexeme ahead during parsing, this helps us know the source length of
     * subexpression tokens.
     */

    infoPtr->prevEnd = infoPtr->next;

    /*
     * Scan over leading white space at the start of a lexeme. 

     */

    src = infoPtr->next;
    numBytes = parsePtr->end - src;
    do {
	char type;
	int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
	src += scanned; numBytes -= scanned;




    } while  (numBytes && (*src == '\n') && (src++,numBytes--));



    parsePtr->term = src;
    if (numBytes == 0) {
	infoPtr->lexeme = END;
	infoPtr->next = src;
	return TCL_OK;
    }

    /*
     * Try to parse the lexeme first as an integer or floating-point
     * number. Don't check for a number if the first character c is
     * "+" or "-". If we did, we might treat a binary operator as unary
     * by mistake, which would eventually cause a syntax error.
     */

    c = *src;
    if ((c != '+') && (c != '-')) {














	CONST char *end = infoPtr->lastChar;




	if ((length = TclParseInteger(src, (end - src)))) {
	    /*


	     * First length bytes look like an integer.  Verify by
	     * attempting the conversion to the largest integer we have.
	     */


	    int code;
	    Tcl_WideInt wide;
	    Tcl_Obj *value = Tcl_NewStringObj(src, length);













	    Tcl_IncrRefCount(value);
	    code = Tcl_GetWideIntFromObj(interp, value, &wide);
	    Tcl_DecrRefCount(value);
	    if (code == TCL_ERROR) {
		parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		return TCL_ERROR;
	    }

            infoPtr->lexeme = LITERAL;
	    infoPtr->start = src;
	    infoPtr->size = length;
            infoPtr->next = (src + length);
	    parsePtr->term = infoPtr->next;
            return TCL_OK;
	} else if ((length = ParseMaxDoubleLength(src, end))) {
	    /*
	     * There are length characters that could be a double.
	     * Let strtod() tells us for sure.  Need a writable copy
	     * so we can set an terminating NULL to keep strtod from
	     * scanning too far.
	     */
	    char *startPtr, *termPtr;
	    double doubleValue;
	    Tcl_DString toParse;



	    errno = 0;
	    Tcl_DStringInit(&toParse);
	    startPtr = Tcl_DStringAppend(&toParse, src, length);
	    doubleValue = strtod(startPtr, &termPtr);
	    Tcl_DStringFree(&toParse);
	    if (termPtr != startPtr) {
		if (errno != 0) {
		    if (interp != NULL) {
			TclExprFloatError(interp, doubleValue);
		    }
		    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
		    return TCL_ERROR;
		}
		
		/*
                 * startPtr was the start of a valid double, copied
		 * from src.
                 */
		
		infoPtr->lexeme = LITERAL;
		infoPtr->start = src;
		if ((termPtr - startPtr) > length) {
		    infoPtr->size = length;
		} else {
		    infoPtr->size = (termPtr - startPtr);
		}
		infoPtr->next = src + infoPtr->size;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    }
	}
    }

    /*
     * Not an integer or double literal. Initialize the lexeme's fields
1718
1719
1720
1721
1722
1723
1724


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
	    return TCL_OK;

	case ':':
	    infoPtr->lexeme = COLON;
	    return TCL_OK;

	case '<':


	    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;
		default:
		    infoPtr->lexeme = LESS;
		    break;
	    }

	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '>':


	    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;
		default:
		    infoPtr->lexeme = GREATER;
		    break;
	    }

	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '=':

	    if (src[1] == '=') {
		infoPtr->lexeme = EQUAL;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    } else {
		infoPtr->lexeme = UNKNOWN;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '!':

	    if (src[1] == '=') {
		infoPtr->lexeme = NEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    } else {
		infoPtr->lexeme = NOT;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '&':

	    if (src[1] == '&') {
		infoPtr->lexeme = AND;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    } else {
		infoPtr->lexeme = BIT_AND;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '^':
	    infoPtr->lexeme = BIT_XOR;
	    return TCL_OK;

	case '|':

	    if (src[1] == '|') {
		infoPtr->lexeme = OR;
		infoPtr->size = 2;
		infoPtr->next = src+2;
	    } else {
		infoPtr->lexeme = BIT_OR;
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '~':
	    infoPtr->lexeme = BIT_NOT;
	    return TCL_OK;

	case 'e':
	    if (src[1] == 'q') {
		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->lexeme = STRNEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else {
		goto checkFuncName;
	    }

	default:
	checkFuncName:


	    offset = Tcl_UtfToUniChar(src, &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;

		    offset = Tcl_UtfToUniChar(src, &ch);






		    c = UCHAR(ch);
		}
		infoPtr->size = (src - infoPtr->start);
		infoPtr->next = src;
		parsePtr->term = infoPtr->next;
		/*
		 * Check for boolean literals (true, false, yes, no, on, off)







>
>
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
>




>
>
|
|
|
|
|
|
|
|
|
|
|
<
<
<
|
>




>
|



<
<





>
|



<
<





>
|



<
<









>
|



<
<









|










|











>
>
|
>
>
>
>
>
>




|
>
|
>
>
>
>
>
>







1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710



1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729



1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740


1741
1742
1743
1744
1745
1746
1747
1748
1749
1750


1751
1752
1753
1754
1755
1756
1757
1758
1759
1760


1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774


1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
	    return TCL_OK;

	case ':':
	    infoPtr->lexeme = COLON;
	    return TCL_OK;

	case '<':
	    infoPtr->lexeme = LESS;
	    if ((infoPtr->lastChar - src) > 1) {
		switch (src[1]) {
		    case '<':
			infoPtr->lexeme = LEFT_SHIFT;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;
		    case '=':
			infoPtr->lexeme = LEQ;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;



		}
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '>':
	    infoPtr->lexeme = GREATER;
	    if ((infoPtr->lastChar - src) > 1) {
		switch (src[1]) {
		    case '>':
			infoPtr->lexeme = RIGHT_SHIFT;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;
		    case '=':
			infoPtr->lexeme = GEQ;
			infoPtr->size = 2;
			infoPtr->next = src+2;
			break;



		}
	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '=':
	    infoPtr->lexeme = UNKNOWN;
	    if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = EQUAL;
		infoPtr->size = 2;
		infoPtr->next = src+2;


	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '!':
	    infoPtr->lexeme = NOT;
	    if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = NEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;


	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '&':
	    infoPtr->lexeme = BIT_AND;
	    if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = AND;
		infoPtr->size = 2;
		infoPtr->next = src+2;


	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '^':
	    infoPtr->lexeme = BIT_XOR;
	    return TCL_OK;

	case '|':
	    infoPtr->lexeme = BIT_OR;
	    if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = OR;
		infoPtr->size = 2;
		infoPtr->next = src+2;


	    }
	    parsePtr->term = infoPtr->next;
	    return TCL_OK;

	case '~':
	    infoPtr->lexeme = BIT_NOT;
	    return TCL_OK;

	case 'e':
	    if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = STREQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else {
		goto checkFuncName;
	    }

	case 'n':
	    if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1)) {
		infoPtr->lexeme = STRNEQ;
		infoPtr->size = 2;
		infoPtr->next = src+2;
		parsePtr->term = infoPtr->next;
		return TCL_OK;
	    } else {
		goto checkFuncName;
	    }

	default:
	checkFuncName:
	    length = (infoPtr->lastChar - src);
	    if (Tcl_UtfCharComplete(src, length)) {
		offset = Tcl_UtfToUniChar(src, &ch);
	    } else {
		char utfBytes[TCL_UTF_MAX];
		memcpy(utfBytes, src, (size_t) length);
		utfBytes[length] = '\0';
		offset = Tcl_UtfToUniChar(utfBytes, &ch);
	    }
	    c = UCHAR(ch);
	    if (isalpha(UCHAR(c))) {	/* INTL: ISO only. */
		infoPtr->lexeme = FUNC_NAME;
		while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
		    src += offset; length -= offset;
		    if (Tcl_UtfCharComplete(src, length)) {
			offset = Tcl_UtfToUniChar(src, &ch);
		    } else {
			char utfBytes[TCL_UTF_MAX];
			memcpy(utfBytes, src, (size_t) length);
			utfBytes[length] = '\0';
			offset = Tcl_UtfToUniChar(utfBytes, &ch);
		    }
		    c = UCHAR(ch);
		}
		infoPtr->size = (src - infoPtr->start);
		infoPtr->next = src;
		parsePtr->term = infoPtr->next;
		/*
		 * Check for boolean literals (true, false, yes, no, on, off)
1897
1898
1899
1900
1901
1902
1903





































































































1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
	    return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *





































































































 * PrependSubExprTokens --
 *
 *	This procedure is called after the operands of an subexpression have
 *	been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
 *	the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
 *	These two tokens are inserted before the operand tokens.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold the new tokens,
 *	additional space is malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
    char *op;			/* Points to first byte of the operator
				 * in the source script. */
    int opBytes;		/* Number of bytes in the operator. */
    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. */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



















|


|







1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
	    return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclParseInteger --
 *
 *	Scans up to numBytes bytes starting at src, and checks whether
 *	the leading bytes look like an integer's string representation.
 *
 * Results:
 *	Returns 0 if the leading bytes do not look like an integer.
 *	Otherwise, returns the number of bytes examined that look
 *	like an integer.  This may be less than numBytes if the integer
 *	is only the leading part of the string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclParseInteger(string, numBytes)
    register CONST char *string;/* The string to examine. */
    register int numBytes;	/* Max number of bytes to scan. */
{
    register CONST char *p = string;

    /* Take care of introductory "0x" */
    if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
	int scanned;
	Tcl_UniChar ch;
	p+=2; numBytes -= 2;
 	scanned = TclParseHex(p, numBytes, &ch);
	if (scanned) {
	    return scanned + 2;
	}
	return 0;
    }
    while (numBytes && isdigit(UCHAR(*p))) {	/* INTL: digit */
	numBytes--; p++;
    }
    if (numBytes == 0) {
        return (p - string);
    }
    if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
        return (p - string);
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ParseMaxDoubleLength --
 *
 *      Scans a sequence of bytes checking that the characters could
 *	be in a string rep of a double.
 *
 * Results:
 *	Returns the number of bytes starting with string, runing to, but
 *	not including end, all of which could be part of a string rep.
 *	of a double.  Only character identity is used, no actual
 *	parsing is done.
 *
 *	The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f', 
 *	'.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x',  and 'X'.
 *	This covers the values "Inf" and "Nan" as well as the
 *	decimal and hexadecimal representations recognized by a
 *	C99-compliant strtod().
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ParseMaxDoubleLength(string, end)
    register CONST char *string;/* The string to examine. */
    CONST char *end;		/* Point to the first character past the end
				 * of the string we are examining. */
{
    CONST char *p = string;
    while (p < end) {
	switch (*p) {
	    case '0': case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9': case 'A': case 'B':
	    case 'C': case 'D': case 'E': case 'F': case 'I': case 'N':
	    case 'P': case 'X': case 'a': case 'b': case 'c': case 'd':
	    case 'e': case 'f': case 'i': case 'n': case 'p': case 'x':
	    case '.': case '+': case '-':
		p++;
		break;
	    default:
		goto done;
	}
    }
    done:
    return (p - string);
}

/*
 *----------------------------------------------------------------------
 *
 * PrependSubExprTokens --
 *
 *	This procedure is called after the operands of an subexpression have
 *	been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
 *	the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
 *	These two tokens are inserted before the operand tokens.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	If there is insufficient space in parsePtr to hold the new tokens,
 *	additional space is malloc-ed.
 *
 *----------------------------------------------------------------------
 */

static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
    CONST char *op;		/* Points to first byte of the operator
				 * in the source script. */
    int opBytes;		/* Number of bytes in the operator. */
    CONST char *src;		/* Points to first byte of the subexpression
				 * in the source script. */
    int srcBytes;		/* Number of bytes in subexpression's
				 * source. */
    int firstIndex;		/* Index of first token already emitted for
				 * operator's first (or only) operand. */
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998

1999
2000
2001
2002
2003
 *----------------------------------------------------------------------
 */

static void
LogSyntaxError(infoPtr, extraInfo)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
    char *extraInfo;		/* String to provide extra information
				 * about the syntax error. */
{
    int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
    char buffer[100];

    if (numBytes > 60) {
	sprintf(buffer, "syntax error in expression \"%.60s...\"",
		infoPtr->originalExpr);
    } else {
	sprintf(buffer, "syntax error in expression \"%s\"",
		infoPtr->originalExpr);
    }

    Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
	    buffer, ": ", extraInfo, (char *) NULL);
    infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
    infoPtr->parsePtr->term = infoPtr->start;
}







|









|
|

>





2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
 *----------------------------------------------------------------------
 */

static void
LogSyntaxError(infoPtr, extraInfo)
    ParseInfo *infoPtr;		/* Holds the parse state for the
				 * expression being parsed. */
    CONST char *extraInfo;	/* String to provide extra information
				 * about the syntax error. */
{
    int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
    char buffer[100];

    if (numBytes > 60) {
	sprintf(buffer, "syntax error in expression \"%.60s...\"",
		infoPtr->originalExpr);
    } else {
	sprintf(buffer, "syntax error in expression \"%.*s\"",
		numBytes, infoPtr->originalExpr);
    }
    Tcl_ResetResult(infoPtr->parsePtr->interp);
    Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
	    buffer, ": ", extraInfo, (char *) NULL);
    infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
    infoPtr->parsePtr->term = infoPtr->start;
}
Changes to generic/tclPlatDecls.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
/*
 * tclPlatDecls.h --
 *
 *	Declarations of platform specific Tcl APIs.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclPlatDecls.h,v 1.12.6.3 2002/06/10 05:33:13 wolfsuit Exp $
 */

#ifndef _TCLPLATDECLS
#define _TCLPLATDECLS

/*
 *  Pull in the typedef of TCHAR for windows.








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
/*
 * tclPlatDecls.h --
 *
 *	Declarations of platform specific Tcl APIs.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclPlatDecls.h,v 1.12.6.4 2002/08/20 20:25:26 das Exp $
 */

#ifndef _TCLPLATDECLS
#define _TCLPLATDECLS

/*
 *  Pull in the typedef of TCHAR for windows.
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
EXTERN int		strncasecmp _ANSI_ARGS_((CONST char * s1, 
				CONST char * s2, size_t n));
/* 8 */
EXTERN int		strcasecmp _ANSI_ARGS_((CONST char * s1, 
				CONST char * s2));
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
/* Slot 0 is reserved */
/* 1 */
EXTERN int		Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
				Tcl_Interp * interp, char * bundleName, 
				int hasResourceFile, int maxPathLen, 
				char * libraryPath));
#endif /* MAC_OSX_TCL */

typedef struct TclPlatStubs {
    int magic;
    struct TclPlatStubHooks *hooks;







<
|

|







71
72
73
74
75
76
77

78
79
80
81
82
83
84
85
86
87
EXTERN int		strncasecmp _ANSI_ARGS_((CONST char * s1, 
				CONST char * s2, size_t n));
/* 8 */
EXTERN int		strcasecmp _ANSI_ARGS_((CONST char * s1, 
				CONST char * s2));
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL

/* 0 */
EXTERN int		Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
				Tcl_Interp * interp, CONST char * bundleName, 
				int hasResourceFile, int maxPathLen, 
				char * libraryPath));
#endif /* MAC_OSX_TCL */

typedef struct TclPlatStubs {
    int magic;
    struct TclPlatStubHooks *hooks;
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
    int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */
    void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */
    Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */
    int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */
    int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
    void *reserved0;
    int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 1 */
#endif /* MAC_OSX_TCL */
} TclPlatStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclPlatStubs *tclPlatStubsPtr;







<
|







98
99
100
101
102
103
104

105
106
107
108
109
110
111
112
    int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */
    void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */
    Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */
    int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */
    int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL

    int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 0 */
#endif /* MAC_OSX_TCL */
} TclPlatStubs;

#ifdef __cplusplus
extern "C" {
#endif
extern TclPlatStubs *tclPlatStubsPtr;
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
#endif
#ifndef strcasecmp
#define strcasecmp \
	(tclPlatStubsPtr->strcasecmp) /* 8 */
#endif
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
/* Slot 0 is reserved */
#ifndef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources \
	(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 1 */
#endif
#endif /* MAC_OSX_TCL */

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#endif /* _TCLPLATDECLS */









<


|










165
166
167
168
169
170
171

172
173
174
175
176
177
178
179
180
181
182
183
184
#endif
#ifndef strcasecmp
#define strcasecmp \
	(tclPlatStubsPtr->strcasecmp) /* 8 */
#endif
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL

#ifndef Tcl_MacOSXOpenBundleResources
#define Tcl_MacOSXOpenBundleResources \
	(tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
#endif
#endif /* MAC_OSX_TCL */

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#endif /* _TCLPLATDECLS */


Changes to generic/tclProc.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.29.2.2 2002/06/10 05:33:13 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclProc.c --
 *
 *	This file contains routines that implement Tcl procedures,
 *	including the "proc" and "uplevel" commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclProc.c,v 1.29.2.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
TclProcInterpProc(clientData, interp, argc, argv)
    ClientData clientData;	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp;		/* Interpreter in which procedure was
				 * invoked. */
    int argc;			/* Count of number of arguments to this
				 * procedure. */
    register char **argv;	/* Argument values. */
{
    register Tcl_Obj *objPtr;
    register int i;
    int result;

    /*
     * This procedure generates an objv array for object arguments that hold







|







794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
TclProcInterpProc(clientData, interp, argc, argv)
    ClientData clientData;	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp;		/* Interpreter in which procedure was
				 * invoked. */
    int argc;			/* Count of number of arguments to this
				 * procedure. */
    register CONST char **argv;	/* Argument values. */
{
    register Tcl_Obj *objPtr;
    register int i;
    int result;

    /*
     * This procedure generates an objv array for object arguments that hold
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
	 */

	if ((i == numArgs) && ((localPtr->name[0] == 'a')
	        && (strcmp(localPtr->name, "args") == 0))) {
	    Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
	    varPtr->value.objPtr = listPtr;
	    Tcl_IncrRefCount(listPtr); /* local var is a reference */
	    varPtr->flags &= ~VAR_UNDEFINED;
	    argCt = 0;
	    break;		/* done processing args */
	} else if (argCt > 0) {
	    Tcl_Obj *objPtr = objv[i];
	    varPtr->value.objPtr = objPtr;
	    varPtr->flags &= ~VAR_UNDEFINED;
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else if (localPtr->defValuePtr != NULL) {
	    Tcl_Obj *objPtr = localPtr->defValuePtr;
	    varPtr->value.objPtr = objPtr;
	    varPtr->flags &= ~VAR_UNDEFINED;
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else {
	    goto incorrectArgs;
	}
	varPtr++;
	localPtr = localPtr->nextPtr;







|





|





|







1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
	 */

	if ((i == numArgs) && ((localPtr->name[0] == 'a')
	        && (strcmp(localPtr->name, "args") == 0))) {
	    Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
	    varPtr->value.objPtr = listPtr;
	    Tcl_IncrRefCount(listPtr); /* local var is a reference */
	    TclClearVarUndefined(varPtr);
	    argCt = 0;
	    break;		/* done processing args */
	} else if (argCt > 0) {
	    Tcl_Obj *objPtr = objv[i];
	    varPtr->value.objPtr = objPtr;
	    TclClearVarUndefined(varPtr);
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else if (localPtr->defValuePtr != NULL) {
	    Tcl_Obj *objPtr = localPtr->defValuePtr;
	    varPtr->value.objPtr = objPtr;
	    TclClearVarUndefined(varPtr);
	    Tcl_IncrRefCount(objPtr);  /* since the local variable now has
					* another reference to object. */
	} else {
	    goto incorrectArgs;
	}
	varPtr++;
	localPtr = localPtr->nextPtr;
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
	fprintf(stdout, "\n");
	fflush(stdout);
    }
#endif /*TCL_COMPILE_DEBUG*/

    iPtr->returnCode = TCL_OK;
    procPtr->refCount++;
    result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0);
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }

    if (result != TCL_OK) {
	result = ProcessProcResultCode(interp, procName, nameLen, result);







|







1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
	fprintf(stdout, "\n");
	fflush(stdout);
    }
#endif /*TCL_COMPILE_DEBUG*/

    iPtr->returnCode = TCL_OK;
    procPtr->refCount++;
    result = TclCompEvalObj(interp, procPtr->bodyPtr);
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }

    if (result != TCL_OK) {
	result = ProcessProcResultCode(interp, procName, nameLen, result);
1417
1418
1419
1420
1421
1422
1423

1424
1425
1426
1427
1428
1429


1430
1431
1432
1433

1434
1435
1436
1437
1438
1439
1440
1441

int
TclUpdateReturnInfo(iPtr)
    Interp *iPtr;		/* Interpreter for which TCL_RETURN
				 * exception is being processed. */
{
    int code;


    code = iPtr->returnCode;
    iPtr->returnCode = TCL_OK;
    if (code == TCL_ERROR) {
	Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
		(iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",


		TCL_GLOBAL_ONLY);
	iPtr->flags |= ERROR_CODE_SET;
	if (iPtr->errorInfo != NULL) {
	    Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,

		    iPtr->errorInfo, TCL_GLOBAL_ONLY);
	    iPtr->flags |= ERR_IN_PROGRESS;
	}
    }
    return code;
}

/*







>




<
|
>
>



|
>
|







1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428

1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444

int
TclUpdateReturnInfo(iPtr)
    Interp *iPtr;		/* Interpreter for which TCL_RETURN
				 * exception is being processed. */
{
    int code;
    char *errorCode;

    code = iPtr->returnCode;
    iPtr->returnCode = TCL_OK;
    if (code == TCL_ERROR) {

	errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
	Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
	        NULL, Tcl_NewStringObj(errorCode, -1),
		TCL_GLOBAL_ONLY);
	iPtr->flags |= ERROR_CODE_SET;
	if (iPtr->errorInfo != NULL) {
	    Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
	            NULL, Tcl_NewStringObj(iPtr->errorInfo, -1),
		    TCL_GLOBAL_ONLY);
	    iPtr->flags |= ERR_IN_PROGRESS;
	}
    }
    return code;
}

/*
Changes to generic/tclStubInit.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.61.4.4 2002/06/10 05:33:13 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Remove macros that will interfere with the definitions below.










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/* 
 * tclStubInit.c --
 *
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.61.4.5 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Remove macros that will interfere with the definitions below.
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
    TCL_STUB_MAGIC,
    NULL,
    NULL, /* 0 */
    TclAccessDeleteProc, /* 1 */
    TclAccessInsertProc, /* 2 */
    TclAllocateFreeObjects, /* 3 */
    NULL, /* 4 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    TclCleanupChildren, /* 5 */
#endif /* UNIX */
#ifdef __WIN32__
    TclCleanupChildren, /* 5 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 5 */
#endif /* MAC_TCL */
    TclCleanupCommand, /* 6 */
    TclCopyAndCollapse, /* 7 */
    TclCopyChannel, /* 8 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    TclCreatePipeline, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    TclCreatePipeline, /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 9 */







|











|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
    TCL_STUB_MAGIC,
    NULL,
    NULL, /* 0 */
    TclAccessDeleteProc, /* 1 */
    TclAccessInsertProc, /* 2 */
    TclAllocateFreeObjects, /* 3 */
    NULL, /* 4 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    TclCleanupChildren, /* 5 */
#endif /* UNIX */
#ifdef __WIN32__
    TclCleanupChildren, /* 5 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 5 */
#endif /* MAC_TCL */
    TclCleanupCommand, /* 6 */
    TclCopyAndCollapse, /* 7 */
    TclCopyChannel, /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    TclCreatePipeline, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    TclCreatePipeline, /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 9 */
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
    TclFindElement, /* 22 */
    TclFindProc, /* 23 */
    TclFormatInt, /* 24 */
    TclFreePackageInfo, /* 25 */
    NULL, /* 26 */
    TclGetDate, /* 27 */
    TclpGetDefaultStdChannel, /* 28 */
    TclGetElementOfIndexedArray, /* 29 */
    NULL, /* 30 */
    TclGetExtension, /* 31 */
    TclGetFrame, /* 32 */
    TclGetInterpProc, /* 33 */
    TclGetIntForIndex, /* 34 */
    TclGetIndexedScalar, /* 35 */
    TclGetLong, /* 36 */
    TclGetLoadedPackages, /* 37 */
    TclGetNamespaceForQualName, /* 38 */
    TclGetObjInterpProc, /* 39 */
    TclGetOpenMode, /* 40 */
    TclGetOriginalCommand, /* 41 */
    TclpGetUserHome, /* 42 */
    TclGlobalInvoke, /* 43 */
    TclGuessPackageName, /* 44 */
    TclHideUnsafeCommands, /* 45 */
    TclInExit, /* 46 */
    TclIncrElementOfIndexedArray, /* 47 */
    TclIncrIndexedScalar, /* 48 */
    TclIncrVar2, /* 49 */
    TclInitCompiledLocals, /* 50 */
    TclInterpInit, /* 51 */
    TclInvoke, /* 52 */
    TclInvokeObjectCommand, /* 53 */
    TclInvokeStringCommand, /* 54 */
    TclIsProc, /* 55 */







|





|











|
|







88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
    TclFindElement, /* 22 */
    TclFindProc, /* 23 */
    TclFormatInt, /* 24 */
    TclFreePackageInfo, /* 25 */
    NULL, /* 26 */
    TclGetDate, /* 27 */
    TclpGetDefaultStdChannel, /* 28 */
    NULL, /* 29 */
    NULL, /* 30 */
    TclGetExtension, /* 31 */
    TclGetFrame, /* 32 */
    TclGetInterpProc, /* 33 */
    TclGetIntForIndex, /* 34 */
    NULL, /* 35 */
    TclGetLong, /* 36 */
    TclGetLoadedPackages, /* 37 */
    TclGetNamespaceForQualName, /* 38 */
    TclGetObjInterpProc, /* 39 */
    TclGetOpenMode, /* 40 */
    TclGetOriginalCommand, /* 41 */
    TclpGetUserHome, /* 42 */
    TclGlobalInvoke, /* 43 */
    TclGuessPackageName, /* 44 */
    TclHideUnsafeCommands, /* 45 */
    TclInExit, /* 46 */
    NULL, /* 47 */
    NULL, /* 48 */
    TclIncrVar2, /* 49 */
    TclInitCompiledLocals, /* 50 */
    TclInterpInit, /* 51 */
    TclInvoke, /* 52 */
    TclInvokeObjectCommand, /* 53 */
    TclInvokeStringCommand, /* 54 */
    TclIsProc, /* 55 */
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
    TclProcCompileProc, /* 92 */
    TclProcDeleteProc, /* 93 */
    TclProcInterpProc, /* 94 */
    NULL, /* 95 */
    TclRenameCommand, /* 96 */
    TclResetShadowedCmdRefs, /* 97 */
    TclServiceIdle, /* 98 */
    TclSetElementOfIndexedArray, /* 99 */
    TclSetIndexedScalar, /* 100 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    TclSetPreInitScript, /* 101 */
#endif /* UNIX */
#ifdef __WIN32__
    TclSetPreInitScript, /* 101 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 101 */
#endif /* MAC_TCL */
    TclSetupEnv, /* 102 */
    TclSockGetPort, /* 103 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    TclSockMinimumBuffers, /* 104 */
#endif /* UNIX */
#ifdef __WIN32__
    TclSockMinimumBuffers, /* 104 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 104 */







|
|
|










|







158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
    TclProcCompileProc, /* 92 */
    TclProcDeleteProc, /* 93 */
    TclProcInterpProc, /* 94 */
    NULL, /* 95 */
    TclRenameCommand, /* 96 */
    TclResetShadowedCmdRefs, /* 97 */
    TclServiceIdle, /* 98 */
    NULL, /* 99 */
    NULL, /* 100 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    TclSetPreInitScript, /* 101 */
#endif /* UNIX */
#ifdef __WIN32__
    TclSetPreInitScript, /* 101 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 101 */
#endif /* MAC_TCL */
    TclSetupEnv, /* 102 */
    TclSockGetPort, /* 103 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    TclSockMinimumBuffers, /* 104 */
#endif /* UNIX */
#ifdef __WIN32__
    TclSockMinimumBuffers, /* 104 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 104 */
245
246
247
248
249
250
251


252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267




268
269
270
271
272
273
274
    TclGetInstructionTable, /* 163 */
    TclExpandCodeArray, /* 164 */
    TclpSetInitialEncodings, /* 165 */
    TclListObjSetElement, /* 166 */
    TclSetStartupScriptPath, /* 167 */
    TclGetStartupScriptPath, /* 168 */
    TclpUtfNcmp2, /* 169 */


};

TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    NULL,
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    TclGetAndDetachPids, /* 0 */
    TclpCloseFile, /* 1 */
    TclpCreateCommandChannel, /* 2 */
    TclpCreatePipe, /* 3 */
    TclpCreateProcess, /* 4 */
    NULL, /* 5 */
    TclpMakeFile, /* 6 */
    TclpOpenFile, /* 7 */
    TclUnixWaitForFile, /* 8 */
    TclpCreateTempFile, /* 9 */




#endif /* UNIX */
#ifdef __WIN32__
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclWinGetServByName, /* 2 */
    TclWinGetSockOpt, /* 3 */
    TclWinGetTclInstance, /* 4 */







>
>





|










>
>
>
>







245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
    TclGetInstructionTable, /* 163 */
    TclExpandCodeArray, /* 164 */
    TclpSetInitialEncodings, /* 165 */
    TclListObjSetElement, /* 166 */
    TclSetStartupScriptPath, /* 167 */
    TclGetStartupScriptPath, /* 168 */
    TclpUtfNcmp2, /* 169 */
    TclCheckInterpTraces, /* 170 */
    TclCheckExecutionTraces, /* 171 */
};

TclIntPlatStubs tclIntPlatStubs = {
    TCL_STUB_MAGIC,
    NULL,
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    TclGetAndDetachPids, /* 0 */
    TclpCloseFile, /* 1 */
    TclpCreateCommandChannel, /* 2 */
    TclpCreatePipe, /* 3 */
    TclpCreateProcess, /* 4 */
    NULL, /* 5 */
    TclpMakeFile, /* 6 */
    TclpOpenFile, /* 7 */
    TclUnixWaitForFile, /* 8 */
    TclpCreateTempFile, /* 9 */
    TclpReaddir, /* 10 */
    TclpLocaltime, /* 11 */
    TclpGmtime, /* 12 */
    TclpInetNtoa, /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
    TclWinConvertError, /* 0 */
    TclWinConvertWSAError, /* 1 */
    TclWinGetServByName, /* 2 */
    TclWinGetSockOpt, /* 3 */
    TclWinGetTclInstance, /* 4 */
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
    Tcl_GetOSTypeFromObj, /* 4 */
    Tcl_SetOSTypeObj, /* 5 */
    Tcl_NewOSTypeObj, /* 6 */
    strncasecmp, /* 7 */
    strcasecmp, /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
    NULL, /* 0 */
    Tcl_MacOSXOpenBundleResources, /* 1 */
#endif /* MAC_OSX_TCL */
};

static TclStubHooks tclStubHooks = {
    &tclPlatStubs,
    &tclIntStubs,
    &tclIntPlatStubs







<
|







348
349
350
351
352
353
354

355
356
357
358
359
360
361
362
    Tcl_GetOSTypeFromObj, /* 4 */
    Tcl_SetOSTypeObj, /* 5 */
    Tcl_NewOSTypeObj, /* 6 */
    strncasecmp, /* 7 */
    strcasecmp, /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL

    Tcl_MacOSXOpenBundleResources, /* 0 */
#endif /* MAC_OSX_TCL */
};

static TclStubHooks tclStubHooks = {
    &tclPlatStubs,
    &tclIntStubs,
    &tclIntPlatStubs
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
    Tcl_Panic, /* 2 */
    Tcl_Alloc, /* 3 */
    Tcl_Free, /* 4 */
    Tcl_Realloc, /* 5 */
    Tcl_DbCkalloc, /* 6 */
    Tcl_DbCkfree, /* 7 */
    Tcl_DbCkrealloc, /* 8 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    NULL, /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 9 */
#endif /* MAC_TCL */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#ifdef __WIN32__
    NULL, /* 10 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 10 */







|








|







370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
    Tcl_Panic, /* 2 */
    Tcl_Alloc, /* 3 */
    Tcl_Free, /* 4 */
    Tcl_Realloc, /* 5 */
    Tcl_DbCkalloc, /* 6 */
    Tcl_DbCkfree, /* 7 */
    Tcl_DbCkrealloc, /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
    NULL, /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 9 */
#endif /* MAC_TCL */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#ifdef __WIN32__
    NULL, /* 10 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 10 */
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
    Tcl_DeleteCommandFromToken, /* 104 */
    Tcl_DeleteEvents, /* 105 */
    Tcl_DeleteEventSource, /* 106 */
    Tcl_DeleteExitHandler, /* 107 */
    Tcl_DeleteHashEntry, /* 108 */
    Tcl_DeleteHashTable, /* 109 */
    Tcl_DeleteInterp, /* 110 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_DetachPids, /* 111 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_DetachPids, /* 111 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 111 */







|







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
    Tcl_DeleteCommandFromToken, /* 104 */
    Tcl_DeleteEvents, /* 105 */
    Tcl_DeleteEventSource, /* 106 */
    Tcl_DeleteExitHandler, /* 107 */
    Tcl_DeleteHashEntry, /* 108 */
    Tcl_DeleteHashTable, /* 109 */
    Tcl_DeleteInterp, /* 110 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_DetachPids, /* 111 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_DetachPids, /* 111 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 111 */
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
    Tcl_GetCommandName, /* 160 */
    Tcl_GetErrno, /* 161 */
    Tcl_GetHostName, /* 162 */
    Tcl_GetInterpPath, /* 163 */
    Tcl_GetMaster, /* 164 */
    Tcl_GetNameOfExecutable, /* 165 */
    Tcl_GetObjResult, /* 166 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
    NULL, /* 167 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 167 */







|







552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
    Tcl_GetCommandName, /* 160 */
    Tcl_GetErrno, /* 161 */
    Tcl_GetHostName, /* 162 */
    Tcl_GetInterpPath, /* 163 */
    Tcl_GetMaster, /* 164 */
    Tcl_GetNameOfExecutable, /* 165 */
    Tcl_GetObjResult, /* 166 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
    NULL, /* 167 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 167 */
585
586
587
588
589
590
591
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
    Tcl_MakeSafe, /* 190 */
    Tcl_MakeTcpClientChannel, /* 191 */
    Tcl_Merge, /* 192 */
    Tcl_NextHashEntry, /* 193 */
    Tcl_NotifyChannel, /* 194 */
    Tcl_ObjGetVar2, /* 195 */
    Tcl_ObjSetVar2, /* 196 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_OpenCommandChannel, /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_OpenCommandChannel, /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 197 */
#endif /* MAC_TCL */
    Tcl_OpenFileChannel, /* 198 */
    Tcl_OpenTcpClient, /* 199 */
    Tcl_OpenTcpServer, /* 200 */
    Tcl_Preserve, /* 201 */
    Tcl_PrintDouble, /* 202 */
    Tcl_PutEnv, /* 203 */
    Tcl_PosixError, /* 204 */
    Tcl_QueueEvent, /* 205 */
    Tcl_Read, /* 206 */
#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */
    Tcl_ReapDetachedProcs, /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_ReapDetachedProcs, /* 207 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 207 */







|

















|







590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
    Tcl_MakeSafe, /* 190 */
    Tcl_MakeTcpClientChannel, /* 191 */
    Tcl_Merge, /* 192 */
    Tcl_NextHashEntry, /* 193 */
    Tcl_NotifyChannel, /* 194 */
    Tcl_ObjGetVar2, /* 195 */
    Tcl_ObjSetVar2, /* 196 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_OpenCommandChannel, /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_OpenCommandChannel, /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 197 */
#endif /* MAC_TCL */
    Tcl_OpenFileChannel, /* 198 */
    Tcl_OpenTcpClient, /* 199 */
    Tcl_OpenTcpServer, /* 200 */
    Tcl_Preserve, /* 201 */
    Tcl_PrintDouble, /* 202 */
    Tcl_PutEnv, /* 203 */
    Tcl_PosixError, /* 204 */
    Tcl_QueueEvent, /* 205 */
    Tcl_Read, /* 206 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
    Tcl_ReapDetachedProcs, /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
    Tcl_ReapDetachedProcs, /* 207 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
    NULL, /* 207 */
Changes to generic/tclTest.c.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
 * Copyright (c) 1993-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.32.2.2 2002/06/10 05:33:13 wolfsuit Exp $
 */

#define TCL_TEST

#include "tclInt.h"
#include "tclPort.h"

/*
 * Required for Testregexp*Cmd
 */
#include "tclRegexp.h"







|



<







9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
 * Copyright (c) 1993-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Ajuba Solutions.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclTest.c,v 1.32.2.3 2002/08/20 20:25:26 das Exp $
 */

#define TCL_TEST

#include "tclInt.h"
#include "tclPort.h"

/*
 * Required for Testregexp*Cmd
 */
#include "tclRegexp.h"
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232


233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301

302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int code));
static void		CleanupTestSetassocdataTests _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static void		CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void		CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int		CmdProc1 _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
static int		CmdProc2 _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
static void		CmdTraceDeleteProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int level, char *command, Tcl_CmdProc *cmdProc,
			    ClientData cmdClientData, int argc,
			    char **argv));
static void		CmdTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int level, char *command,
			    Tcl_CmdProc *cmdProc, ClientData cmdClientData,
                            int argc, char **argv));
static int		CreatedCommandProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int argc, char **argv));
static int		CreatedCommandProc2 _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int argc, char **argv));
static void		DelCallbackProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static int		DelCmdProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
static void		DelDeleteProc _ANSI_ARGS_((ClientData clientData));
static void		EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
static int		EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst,
			    int dstLen, int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static int		EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst,
			    int dstLen, int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static void		ExitProcEven _ANSI_ARGS_((ClientData clientData));
static void		ExitProcOdd _ANSI_ARGS_((ClientData clientData));
static int              GetTimesCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int argc, char **argv));
static void		MainLoop _ANSI_ARGS_((void));
static int              NoopCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int argc, char **argv));
static int              NoopObjCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
						   Tcl_Interp* interp,
						   int level,
						   CONST char* command,
						   Tcl_Command commandToken,
						   int objc,
						   Tcl_Obj *CONST objv[] ));
static void		ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
static void		PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
						Tcl_Parse *parsePtr));
static void		SpecialFree _ANSI_ARGS_((char *blockPtr));
static int		StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int		TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		PretendTclpAccess _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestAccessProc1 _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestAccessProc2 _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestAccessProc3 _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestasyncCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestchmodCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestdcallCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestdelCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestdstringCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, 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, char **argv));
static int		TestfileCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));


static int		TestfeventCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestgetvarfullnameCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
		            Tcl_Interp *interp, int argc, char **argv));
static int		TestlinkCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestMathFunc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, Tcl_Value *args,
			    Tcl_Value *resultPtr));
static int		TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, Tcl_Value *args,
			    Tcl_Value *resultPtr));
static int		TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static Tcl_Channel	PretendTclpOpenFileChannel _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static Tcl_Channel	TestOpenFileChannelProc1 _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static Tcl_Channel	TestOpenFileChannelProc2 _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static Tcl_Channel	TestOpenFileChannelProc3 _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static int		TestpanicCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestregexpXflags _ANSI_ARGS_((char *string,
			    int length, int *cflagsPtr, int *eflagsPtr));
static int		TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
static int		TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestsetCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestsetobjerrorcodeCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		TestopenfilechannelprocCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));

static int		TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		PretendTclpStat _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TestStatProc1 _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TestStatProc2 _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TestStatProc3 _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestupvarCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int              TestWrongNumArgsObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int              TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		TestChannelCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char **argv));
/* Filesystem testing */

static int		TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));

static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2));

static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr);

static int		TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
			    Tcl_StatBuf *buf));
static int		TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
			    int mode));
static Tcl_Channel	TestReportOpenFileChannel _ANSI_ARGS_ ((
			    Tcl_Interp *interp, Tcl_Obj *fileName,
			    CONST char *modeString, int permissions));
static int		TestReportMatchInDirectory _ANSI_ARGS_ ((
			    Tcl_Interp *interp, Tcl_Obj *resultPtr,
			    Tcl_Obj *dirPtr, CONST char *pattern,
			    Tcl_GlobTypeData *types));
static int		TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
static int		TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
			    Tcl_StatBuf *buf));
static int		TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
			    Tcl_Obj *dst));
static int		TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
static int		TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
			    Tcl_Obj *dst));
static int		TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
static int		TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
			    Tcl_Obj *dst, Tcl_Obj **errorPtr));
static int		TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
			    int recursive, Tcl_Obj **errorPtr));
static int		TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
			    Tcl_Obj *fileName, CONST char *sym1,
			    CONST char *sym2, Tcl_PackageInitProc **proc1Ptr,
			    Tcl_PackageInitProc **proc2Ptr,
			    ClientData *clientDataPtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr));
static Tcl_Obj *	TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
			    Tcl_Obj *to));
static CONST char**	TestReportFileAttrStrings _ANSI_ARGS_ ((
			    Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int		TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
			    int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int		TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
			    int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));
static int		TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,







|

|











|


|



|















|


|
















|









|

|

|

|

|

|

|

|

|

|










|

|




|


>
>

|

|

|




|

|










|

|

|













|



















|

|



|
|
>

|

|









|

|

|







|

|
















|


















|
<
<
|


|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367


368
369
370
371
372
373
374
375
376
377
378
static int		AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int code));
static void		CleanupTestSetassocdataTests _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp));
static void		CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void		CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int		CmdProc1 _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		CmdProc2 _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static void		CmdTraceDeleteProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int level, char *command, Tcl_CmdProc *cmdProc,
			    ClientData cmdClientData, int argc,
			    char **argv));
static void		CmdTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int level, char *command,
			    Tcl_CmdProc *cmdProc, ClientData cmdClientData,
                            int argc, char **argv));
static int		CreatedCommandProc _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int argc, CONST char **argv));
static int		CreatedCommandProc2 _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int argc, CONST char **argv));
static void		DelCallbackProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp));
static int		DelCmdProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static void		DelDeleteProc _ANSI_ARGS_((ClientData clientData));
static void		EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
static int		EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst,
			    int dstLen, int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static int		EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData,
			    CONST char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst,
			    int dstLen, int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr));
static void		ExitProcEven _ANSI_ARGS_((ClientData clientData));
static void		ExitProcOdd _ANSI_ARGS_((ClientData clientData));
static int              GetTimesCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int argc, CONST char **argv));
static void		MainLoop _ANSI_ARGS_((void));
static int              NoopCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int argc, CONST char **argv));
static int              NoopObjCmd _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
						   Tcl_Interp* interp,
						   int level,
						   CONST char* command,
						   Tcl_Command commandToken,
						   int objc,
						   Tcl_Obj *CONST objv[] ));
static void		ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
static void		PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
						Tcl_Parse *parsePtr));
static void		SpecialFree _ANSI_ARGS_((char *blockPtr));
static int		StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int		TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		PretendTclpAccess _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestAccessProc1 _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestAccessProc2 _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestAccessProc3 _ANSI_ARGS_((CONST char *path,
			   int mode));
static int		TestasyncCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestchmodCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestdcallCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestdelCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestdstringCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));
static int		TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestfileCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int		TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int		TestfeventCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestgetvarfullnameCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
		            Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestlinkCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestMathFunc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, Tcl_Value *args,
			    Tcl_Value *resultPtr));
static int		TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, Tcl_Value *args,
			    Tcl_Value *resultPtr));
static int		TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static Tcl_Channel	PretendTclpOpenFileChannel _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static Tcl_Channel	TestOpenFileChannelProc1 _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static Tcl_Channel	TestOpenFileChannelProc2 _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static Tcl_Channel	TestOpenFileChannelProc3 _ANSI_ARGS_((
			    Tcl_Interp *interp, CONST char *fileName,
			    CONST char *modeString, int permissions));
static int		TestpanicCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static int		TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestregexpXflags _ANSI_ARGS_((char *string,
			    int length, int *cflagsPtr, int *eflagsPtr));
static int		TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *CONST objv[]));
static void		TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
static int		TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestsetCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestsetobjerrorcodeCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		TestopenfilechannelprocCmd _ANSI_ARGS_((
			    ClientData dummy, Tcl_Interp *interp, int argc,
			    CONST char **argv));
static int		TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		PretendTclpStat _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TestStatProc1 _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TestStatProc2 _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TestStatProc3 _ANSI_ARGS_((CONST char *path,
			    struct stat *buf));
static int		TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestupvarCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int              TestWrongNumArgsObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int              TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *CONST objv[]));
static int		TestChannelCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, CONST char **argv));
/* Filesystem testing */

static int		TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int objc, 
			    Tcl_Obj *CONST objv[]));

static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2));

static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr);

static int		TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
			    Tcl_StatBuf *buf));
static int		TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
			    int mode));
static Tcl_Channel	TestReportOpenFileChannel _ANSI_ARGS_ ((
			    Tcl_Interp *interp, Tcl_Obj *fileName,
			    int mode, int permissions));
static int		TestReportMatchInDirectory _ANSI_ARGS_ ((
			    Tcl_Interp *interp, Tcl_Obj *resultPtr,
			    Tcl_Obj *dirPtr, CONST char *pattern,
			    Tcl_GlobTypeData *types));
static int		TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
static int		TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
			    Tcl_StatBuf *buf));
static int		TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
			    Tcl_Obj *dst));
static int		TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
static int		TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
			    Tcl_Obj *dst));
static int		TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
static int		TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
			    Tcl_Obj *dst, Tcl_Obj **errorPtr));
static int		TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
			    int recursive, Tcl_Obj **errorPtr));
static int		TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
			    Tcl_Obj *fileName, 


			    Tcl_LoadHandle *handlePtr,
			    Tcl_FSUnloadFileProc **unloadProcPtr));
static Tcl_Obj *	TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
			    Tcl_Obj *to, int linkType));
static CONST char**	TestReportFileAttrStrings _ANSI_ARGS_ ((
			    Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int		TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
			    int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int		TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
			    int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));
static int		TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,
521
522
523
524
525
526
527


528
529
530
531
532
533
534
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
            (Tcl_CmdDeleteProc *) NULL);


    Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testgetvarfullname",







>
>







521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
            (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd, 
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
            (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "testgetvarfullname",
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672

	/* ARGSUSED */
static int
TestasyncCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TestAsyncHandler *asyncPtr, *prevPtr;
    int id, code;
    static int nextId = 1;
    char buf[TCL_INTEGER_SPACE];

    if (argc < 2) {







|







660
661
662
663
664
665
666
667
668
669
670
671
672
673
674

	/* ARGSUSED */
static int
TestasyncCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    TestAsyncHandler *asyncPtr, *prevPtr;
    int id, code;
    static int nextId = 1;
    char buf[TCL_INTEGER_SPACE];

    if (argc < 2) {
732
733
734
735
736
737
738
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
	for (asyncPtr = firstHandler; asyncPtr != NULL;
		asyncPtr = asyncPtr->nextPtr) {
	    if (asyncPtr->id == id) {
		Tcl_AsyncMark(asyncPtr->handler);
		break;
	    }
	}
	Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
	return code;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create, delete, int, or mark",
		(char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static int
AsyncHandlerProc(clientData, interp, code)
    ClientData clientData;	/* Pointer to TestAsyncHandler structure. */
    Tcl_Interp *interp;		/* Interpreter in which command was
				 * executed, or NULL. */
    int code;			/* Current return code from command. */
{
    TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
    CONST char *listArgv[4];
    char string[TCL_INTEGER_SPACE], *cmd;

    TclFormatInt(string, code);
    listArgv[0] = asyncPtr->command;
    listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
    listArgv[2] = string;
    listArgv[3] = NULL;
    cmd = Tcl_Merge(3, listArgv);
    if (interp != NULL) {
	code = Tcl_Eval(interp, cmd);
    } else {
	/*
	 * this should not happen, but by definition of how async
	 * handlers are invoked, it's possible.  Better error
	 * checking is needed here.
	 */
    }
    ckfree(cmd);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TestcmdinfoCmd --







|


















|
|
















|







734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
	for (asyncPtr = firstHandler; asyncPtr != NULL;
		asyncPtr = asyncPtr->nextPtr) {
	    if (asyncPtr->id == id) {
		Tcl_AsyncMark(asyncPtr->handler);
		break;
	    }
	}
	Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
	return code;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": must be create, delete, int, or mark",
		(char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

static int
AsyncHandlerProc(clientData, interp, code)
    ClientData clientData;	/* Pointer to TestAsyncHandler structure. */
    Tcl_Interp *interp;		/* Interpreter in which command was
				 * executed, or NULL. */
    int code;			/* Current return code from command. */
{
    TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
    CONST char *listArgv[4], *cmd;
    char string[TCL_INTEGER_SPACE];

    TclFormatInt(string, code);
    listArgv[0] = asyncPtr->command;
    listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
    listArgv[2] = string;
    listArgv[3] = NULL;
    cmd = Tcl_Merge(3, listArgv);
    if (interp != NULL) {
	code = Tcl_Eval(interp, cmd);
    } else {
	/*
	 * this should not happen, but by definition of how async
	 * handlers are invoked, it's possible.  Better error
	 * checking is needed here.
	 */
    }
    ckfree((char *)cmd);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TestcmdinfoCmd --
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811

	/* ARGSUSED */
static int
TestcmdinfoCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_CmdInfo info;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option cmdName\"", (char *) NULL);
	return TCL_ERROR;







|







799
800
801
802
803
804
805
806
807
808
809
810
811
812
813

	/* ARGSUSED */
static int
TestcmdinfoCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_CmdInfo info;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option cmdName\"", (char *) NULL);
	return TCL_ERROR;
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897

	/*ARGSUSED*/
static int
CmdProc1(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
	    (char *) NULL);
    return TCL_OK;
}

	/*ARGSUSED*/
static int
CmdProc2(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
	    (char *) NULL);
    return TCL_OK;
}

static void







|












|







872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899

	/*ARGSUSED*/
static int
CmdProc1(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
	    (char *) NULL);
    return TCL_OK;
}

	/*ARGSUSED*/
static int
CmdProc2(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
	    (char *) NULL);
    return TCL_OK;
}

static void
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946

	/* ARGSUSED */
static int
TestcmdtokenCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_Command token;
    int *l;
    char buf[30];

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],







|







934
935
936
937
938
939
940
941
942
943
944
945
946
947
948

	/* ARGSUSED */
static int
TestcmdtokenCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_Command token;
    int *l;
    char buf[30];

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010

	/* ARGSUSED */
static int
TestcmdtraceCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_DString buffer;
    int result;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option script\"", (char *) NULL);







|







998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012

	/* ARGSUSED */
static int
TestcmdtraceCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_DString buffer;
    int result;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option script\"", (char *) NULL);
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
 */

static int
TestcreatecommandCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "create") == 0) {







|







1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
 */

static int
TestcreatecommandCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (strcmp(argv[1], "create") == 0) {
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
}

static int
CreatedCommandProc(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_CmdInfo info;
    int found;

    found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
	    &info);
    if (!found) {







|







1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
}

static int
CreatedCommandProc(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_CmdInfo info;
    int found;

    found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
	    &info);
    if (!found) {
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
}

static int
CreatedCommandProc2(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_CmdInfo info;
    int found;

    found = Tcl_GetCommandInfo(interp, "value:at:", &info);
    if (!found) {
	Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",







|







1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
}

static int
CreatedCommandProc2(clientData, interp, argc, argv)
    ClientData clientData;		/* String to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_CmdInfo info;
    int found;

    found = Tcl_GetCommandInfo(interp, "value:at:", &info);
    if (!found) {
	Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278

	/* ARGSUSED */
static int
TestdcallCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int i, id;

    delInterp = Tcl_CreateInterp();
    Tcl_DStringInit(&delString);
    for (i = 1; i < argc; i++) {
	if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {







|







1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280

	/* ARGSUSED */
static int
TestdcallCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int i, id;

    delInterp = Tcl_CreateInterp();
    Tcl_DStringInit(&delString);
    for (i = 1; i < argc; i++) {
	if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344

	/* ARGSUSED */
static int
TestdelCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    DelCmd *dPtr;
    Tcl_Interp *slave;

    if (argc != 4) {
	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
	return TCL_ERROR;







|







1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346

	/* ARGSUSED */
static int
TestdelCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    DelCmd *dPtr;
    Tcl_Interp *slave;

    if (argc != 4) {
	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
	return TCL_ERROR;
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
}

static int
DelCmdProc(clientData, interp, argc, argv)
    ClientData clientData;		/* String result to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    DelCmd *dPtr = (DelCmd *) clientData;

    Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
    ckfree(dPtr->deleteCmd);
    ckfree((char *) dPtr);
    return TCL_OK;







|







1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
}

static int
DelCmdProc(clientData, interp, argc, argv)
    ClientData clientData;		/* String result to return. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    DelCmd *dPtr = (DelCmd *) clientData;

    Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
    ckfree(dPtr->deleteCmd);
    ckfree((char *) dPtr);
    return TCL_OK;
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
 */

static int
TestdelassocdataCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " data_key\"", (char *) NULL);
        return TCL_ERROR;
    }
    Tcl_DeleteAssocData(interp, argv[1]);







|







1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
 */

static int
TestdelassocdataCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " data_key\"", (char *) NULL);
        return TCL_ERROR;
    }
    Tcl_DeleteAssocData(interp, argv[1]);
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453

	/* ARGSUSED */
static int
TestdstringCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int count;

    if (argc < 2) {
	wrongNumArgs:
	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
	return TCL_ERROR;







|







1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455

	/* ARGSUSED */
static int
TestdstringCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int count;

    if (argc < 2) {
	wrongNumArgs:
	Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
	return TCL_ERROR;
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
 */

static int
TestexithandlerCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int value;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " create|delete value\"", (char *) NULL);
        return TCL_ERROR;







|







1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
 */

static int
TestexithandlerCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int value;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " create|delete value\"", (char *) NULL);
        return TCL_ERROR;
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
 */

static int
TestexprlongCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    long exprResult;
    char buf[4 + TCL_INTEGER_SPACE];
    int result;
    
    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprLong(interp, "4+1", &exprResult);







|







1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
 */

static int
TestexprlongCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    long exprResult;
    char buf[4 + TCL_INTEGER_SPACE];
    int result;
    
    Tcl_SetResult(interp, "This is a result", TCL_STATIC);
    result = Tcl_ExprLong(interp, "4+1", &exprResult);
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966




































































1967
1968
1969
1970
1971
1972
1973
 */

static int
TestexprstringCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " expression\"", (char *) NULL);
        return TCL_ERROR;
    }
    return Tcl_ExprString(interp, argv[1]);
}





































































/*
 *----------------------------------------------------------------------
 *
 * TestgetassocdataCmd --
 *
 *	This procedure implements the "testgetassocdata" command. It is







|








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
 */

static int
TestexprstringCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " expression\"", (char *) NULL);
        return TCL_ERROR;
    }
    return Tcl_ExprString(interp, argv[1]);
}

/*
 *----------------------------------------------------------------------
 *
 * TestfilelinkCmd --
 *
 *	This procedure implements the "testfilelink" command.  It is used
 *	to test the effects of creating and manipulating filesystem links
 *	in Tcl.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	May create a link on disk.
 *
 *----------------------------------------------------------------------
 */

static int
TestfilelinkCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    Tcl_Obj *contents;

    if (objc < 2 || objc > 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");
	return TCL_ERROR;
    }
    
    if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
	return TCL_ERROR;
    }
    
    if (objc == 3) {
	/* Create link from source to target */
	contents = Tcl_FSLink(objv[1], objv[2], 
			TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
	if (contents == NULL) {
	    Tcl_AppendResult(interp, "could not create link from \"", 
		    Tcl_GetString(objv[1]), "\" to \"", 
		    Tcl_GetString(objv[2]), "\": ", 
		    Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
    } else {
	/* Read link */
	contents = Tcl_FSLink(objv[1], NULL, 0);
	if (contents == NULL) {
	    Tcl_AppendResult(interp, "could not read link \"", 
		    Tcl_GetString(objv[1]), "\": ", 
		    Tcl_PosixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
    }
    Tcl_SetObjResult(interp, contents);
    if (objc == 2) {
	/* 
	 * If we are creating a link, this will actually just
	 * be objv[3], and we don't own it
	 */
	Tcl_DecrRefCount(contents);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TestgetassocdataCmd --
 *
 *	This procedure implements the "testgetassocdata" command. It is
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
 */

static int
TestgetassocdataCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *res;
    
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " data_key\"", (char *) NULL);
        return TCL_ERROR;







|







2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
 */

static int
TestgetassocdataCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    char *res;
    
    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
                " data_key\"", (char *) NULL);
        return TCL_ERROR;
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
 */

static int
TestgetplatformCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    static CONST char *platformStrings[] = { "unix", "mac", "windows" };
    TclPlatformType *platform;

#ifdef __WIN32__
    platform = TclWinGetPlatform();
#else







|







2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
 */

static int
TestgetplatformCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    static CONST char *platformStrings[] = { "unix", "mac", "windows" };
    TclPlatformType *platform;

#ifdef __WIN32__
    platform = TclWinGetPlatform();
#else
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080

	/* ARGSUSED */
static int
TestinterpdeleteCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_Interp *slaveToDelete;

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                " path\"", (char *) NULL);
        return TCL_ERROR;







|







2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150

	/* ARGSUSED */
static int
TestinterpdeleteCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_Interp *slaveToDelete;

    if (argc != 2) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                " path\"", (char *) NULL);
        return TCL_ERROR;
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121

	/* ARGSUSED */
static int
TestlinkCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    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;







|







2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191

	/* ARGSUSED */
static int
TestlinkCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    static int intVar = 43;
    static int boolVar = 4;
    static double realVar = 1.23;
    static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
    static char *stringVar = NULL;
    static int created = 0;
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
TestparsevarObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    CONST char *value;
    char *name, *termPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName");
	return TCL_ERROR;
    }
    name = Tcl_GetString(objv[1]);
    value = Tcl_ParseVar(interp, name, &termPtr);







|







2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
TestparsevarObjCmd(clientData, interp, objc, objv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    CONST char *value;
    CONST char *name, *termPtr;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName");
	return TCL_ERROR;
    }
    name = Tcl_GetString(objv[1]);
    value = Tcl_ParseVar(interp, name, &termPtr);
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
 */

static int
TestsetassocdataCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *buf;
    char *oldData;
    Tcl_InterpDeleteProc *procPtr;
    
    if (argc != 3) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],







|







3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
 */

static int
TestsetassocdataCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    char *buf;
    char *oldData;
    Tcl_InterpDeleteProc *procPtr;
    
    if (argc != 3) {
        Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
 */

static int
TestsetplatformCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    size_t length;
    TclPlatformType *platform;

#ifdef __WIN32__
    platform = TclWinGetPlatform();
#else







|







3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
 */

static int
TestsetplatformCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    size_t length;
    TclPlatformType *platform;

#ifdef __WIN32__
    platform = TclWinGetPlatform();
#else
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
 */

static int
TeststaticpkgCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int safe, loaded;

    if (argc != 4) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
		argv[0], " pkgName safe loaded\"", (char *) NULL);
	return TCL_ERROR;







|







3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
 */

static int
TeststaticpkgCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int safe, loaded;

    if (argc != 4) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
		argv[0], " pkgName safe loaded\"", (char *) NULL);
	return TCL_ERROR;
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
 */

static int
TesttranslatefilenameCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_DString buffer;
    CONST char *result;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
		argv[0], " path\"", (char *) NULL);







|







3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
 */

static int
TesttranslatefilenameCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_DString buffer;
    CONST char *result;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
		argv[0], " path\"", (char *) NULL);
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404

	/* ARGSUSED */
static int
TestupvarCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int flags = 0;
    
    if ((argc != 5) && (argc != 6)) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
		argv[0], " level name ?name2? dest global\"", (char *) NULL);
	return TCL_ERROR;







|







3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474

	/* ARGSUSED */
static int
TestupvarCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int flags = 0;
    
    if ((argc != 5) && (argc != 6)) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"",
		argv[0], " level name ?name2? dest global\"", (char *) NULL);
	return TCL_ERROR;
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496

	/* ARGSUSED */
static int
TestfeventCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    static Tcl_Interp *interp2 = NULL;
    int code;
    Tcl_Channel chan;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],







|







3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566

	/* ARGSUSED */
static int
TestfeventCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    static Tcl_Interp *interp2 = NULL;
    int code;
    Tcl_Channel chan;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
            return TCL_ERROR;
        }
    } else if (strcmp(argv[1], "create") == 0) {
	if (interp2 != NULL) {
            Tcl_DeleteInterp(interp2);
	}
        interp2 = Tcl_CreateInterp();
	return TCL_OK;
    } else if (strcmp(argv[1], "delete") == 0) {
	if (interp2 != NULL) {
            Tcl_DeleteInterp(interp2);
	}
	interp2 = NULL;
    } else if (strcmp(argv[1], "share") == 0) {
        if (interp2 != NULL) {







|







3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
            return TCL_ERROR;
        }
    } else if (strcmp(argv[1], "create") == 0) {
	if (interp2 != NULL) {
            Tcl_DeleteInterp(interp2);
	}
        interp2 = Tcl_CreateInterp();
	return Tcl_Init(interp2);
    } else if (strcmp(argv[1], "delete") == 0) {
	if (interp2 != NULL) {
            Tcl_DeleteInterp(interp2);
	}
	interp2 = NULL;
    } else if (strcmp(argv[1], "share") == 0) {
        if (interp2 != NULL) {
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
 */

static int
TestpanicCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *argString;
    
    /*
     *  Put the arguments into a var args structure
     *  Append all of the arguments together separated by spaces
     */

    argString = Tcl_Merge(argc-1, (CONST char **) argv+1);
    panic(argString);
    ckfree(argString);
 
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *







|

|






|

|







3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
 */

static int
TestpanicCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    CONST char *argString;
    
    /*
     *  Put the arguments into a var args structure
     *  Append all of the arguments together separated by spaces
     */

    argString = Tcl_Merge(argc-1, argv+1);
    panic(argString);
    ckfree((char *)argString);
 
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
 */
 
static int
TestchmodCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int i, mode;
    char *rest;

    if (argc < 2) {
	usage:
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],







|







3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
 */
 
static int
TestchmodCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int i, mode;
    char *rest;

    if (argc < 2) {
	usage:
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
 */

static int
GetTimesCmd(unused, interp, argc, argv)
    ClientData unused;		/* Unused. */
    Tcl_Interp *interp;		/* The current interpreter. */
    int argc;			/* The number of arguments. */
    char **argv;		/* The argument strings. */
{
    Interp *iPtr = (Interp *) interp;
    int i, n;
    double timePer;
    Tcl_Time start, stop;
    Tcl_Obj *objPtr;
    Tcl_Obj **objv;







|







3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
 */

static int
GetTimesCmd(unused, interp, argc, argv)
    ClientData unused;		/* Unused. */
    Tcl_Interp *interp;		/* The current interpreter. */
    int argc;			/* The number of arguments. */
    CONST char **argv;		/* The argument strings. */
{
    Interp *iPtr = (Interp *) interp;
    int i, n;
    double timePer;
    Tcl_Time start, stop;
    Tcl_Obj *objPtr;
    Tcl_Obj **objv;
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
 */

static int
NoopCmd(unused, interp, argc, argv)
    ClientData unused;		/* Unused. */
    Tcl_Interp *interp;		/* The current interpreter. */
    int argc;			/* The number of arguments. */
    char **argv;		/* The argument strings. */
{
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *







|







4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
 */

static int
NoopCmd(unused, interp, argc, argv)
    ClientData unused;		/* Unused. */
    Tcl_Interp *interp;		/* The current interpreter. */
    int argc;			/* The number of arguments. */
    CONST char **argv;		/* The argument strings. */
{
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046

	/* ARGSUSED */
static int
TestsetCmd(data, interp, argc, argv)
    ClientData data;			/* Additional flags for Get/SetVar2. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int flags = (int) data;
    CONST char *value;

    if (argc == 2) {
        Tcl_SetResult(interp, "before get", TCL_STATIC);
	value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);







|







4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116

	/* ARGSUSED */
static int
TestsetCmd(data, interp, argc, argv)
    ClientData data;			/* Additional flags for Get/SetVar2. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int flags = (int) data;
    CONST char *value;

    if (argc == 2) {
        Tcl_SetResult(interp, "before get", TCL_STATIC);
	value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
 */

static int
TeststatprocCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TclStatProc_ *proc;
    int retVal;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arg\"", (char *) NULL);







|







4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
 */

static int
TeststatprocCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    TclStatProc_ *proc;
    int retVal;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arg\"", (char *) NULL);
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
 */

static int
TestmainthreadCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
  if (argc == 1) {
      Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
      Tcl_SetObjResult(interp, idObj);
      return TCL_OK;
  } else {
      Tcl_SetResult(interp, "wrong # args", TCL_STATIC);







|







4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
 */

static int
TestmainthreadCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
  if (argc == 1) {
      Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
      Tcl_SetObjResult(interp, idObj);
      return TCL_OK;
  } else {
      Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
 */

static int
TestsetmainloopCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
  exitMainLoop = 0;
  Tcl_SetMainLoop(MainLoop);
  return TCL_OK;
}

/*







|







4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
 */

static int
TestsetmainloopCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
  exitMainLoop = 0;
  Tcl_SetMainLoop(MainLoop);
  return TCL_OK;
}

/*
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
 */

static int
TestexitmainloopCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
  exitMainLoop = 1;
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------







|







4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
 */

static int
TestexitmainloopCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
  exitMainLoop = 1;
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
 */

static int
TestaccessprocCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TclAccessProc_ *proc;
    int retVal;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arg\"", (char *) NULL);







|







4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
 */

static int
TestaccessprocCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    TclAccessProc_ *proc;
    int retVal;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arg\"", (char *) NULL);
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
 */

static int
TestopenfilechannelprocCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    TclOpenFileChannelProc_ *proc;
    int retVal;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arg\"", (char *) NULL);







|







4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
 */

static int
TestopenfilechannelprocCmd (dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    register Tcl_Interp *interp;	/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    TclOpenFileChannelProc_ *proc;
    int retVal;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		argv[0], " option arg\"", (char *) NULL);
4697
4698
4699
4700
4701
4702
4703






4704
4705
4706
4707














4708
4709
4710
4711
4712
4713
4714
    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(fileName, -1);
    Tcl_IncrRefCount(pathPtr);
    ret = TclpOpenFileChannel(interp, pathPtr, modeString, permissions);
    Tcl_DecrRefCount(pathPtr);














    return ret;
}

static Tcl_Channel
TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
                                         * can be NULL. */







>
>
>
>
>
>
|

|

>
>
>
>
>
>
>
>
>
>
>
>
>
>







4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
    CONST char *modeString;             /* A list of POSIX open modes or
					 * a string such as "rw". */
    int permissions;                    /* If the open involves creating a
					 * file, with what modes to create
					 * it? */
{
    Tcl_Channel ret;
    int mode, seekFlag;
    Tcl_Obj *pathPtr;
    mode = TclGetOpenMode(interp, modeString, &seekFlag);
    if (mode == -1) {
	return NULL;
    }
    pathPtr = Tcl_NewStringObj(fileName, -1);
    Tcl_IncrRefCount(pathPtr);
    ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
    Tcl_DecrRefCount(pathPtr);
    if (ret != NULL) {
	if (seekFlag) {
	    if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
		if (interp != (Tcl_Interp *) NULL) {
		    Tcl_AppendResult(interp,
		      "could not seek to end of file while opening \"",
		      fileName, "\": ", 
		      Tcl_PosixError(interp), (char *) NULL);
		}
		Tcl_Close(NULL, ret);
		return NULL;
	    }
	}
    }
    return ret;
}

static Tcl_Channel
TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
                                         * can be NULL. */
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826

	/* ARGSUSED */
static int
TestChannelCmd(clientData, interp, argc, argv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter for result. */
    int argc;			/* Count of additional args. */
    char **argv;		/* Additional arg strings. */
{
    char *cmdName;		/* Sub command. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashSearch hSearch;	/* Search variable. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* state info for channel */
    Tcl_Channel chan;		/* The opaque type. */
    size_t len;			/* Length of subcommand string. */







|

|







4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916

	/* ARGSUSED */
static int
TestChannelCmd(clientData, interp, argc, argv)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter for result. */
    int argc;			/* Count of additional args. */
    CONST char **argv;		/* Additional arg strings. */
{
    CONST char *cmdName;	/* Sub command. */
    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
    Tcl_HashSearch hSearch;	/* Search variable. */
    Tcl_HashEntry *hPtr;	/* Search variable. */
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* state info for channel */
    Tcl_Channel chan;		/* The opaque type. */
    size_t len;			/* Length of subcommand string. */
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258

	/* ARGSUSED */
static int
TestChannelEventCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_Obj *resultListPtr;
    Channel *chanPtr;
    ChannelState *statePtr;	/* state info for channel */
    EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
    char *cmd;
    int index, i, mask, len;

    if ((argc < 3) || (argc > 5)) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                " channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
        return TCL_ERROR;
    }







|





|







5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348

	/* ARGSUSED */
static int
TestChannelEventCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_Obj *resultListPtr;
    Channel *chanPtr;
    ChannelState *statePtr;	/* state info for channel */
    EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
    CONST char *cmd;
    int index, i, mask, len;

    if ((argc < 3) || (argc > 5)) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
                " channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
        return TCL_ERROR;
    }
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
static int
TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    CONST char *ary[] = {
	"a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
    };
    int idx,target;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
	return TCL_ERROR;







|







5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
static int
TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    char *ary[] = {
	"a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
    };
    int idx,target;

    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
	return TCL_ERROR;
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
    Tcl_Obj *path;		/* Path of file to access (in current CP). */
    int mode;                   /* Permission setting. */
{
    TestReport("access",path,NULL);
    return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
TestReportOpenFileChannel(interp, fileName, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
					 * can be NULL. */
    Tcl_Obj *fileName;                  /* 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? */
{
    TestReport("open",fileName, NULL);
    return Tcl_FSOpenFileChannel(interp, TestReportGetNativePath(fileName),
				 modeString, permissions);
}

static int
TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive results. */
    Tcl_Obj *resultPtr;		/* Directory separators to pass to TclDoGlob. */
    Tcl_Obj *dirPtr;	        /* Contains path to directory to search. */







|



|
<





|
|







5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797

5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
    Tcl_Obj *path;		/* Path of file to access (in current CP). */
    int mode;                   /* Permission setting. */
{
    TestReport("access",path,NULL);
    return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
TestReportOpenFileChannel(interp, fileName, mode, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
					 * can be NULL. */
    Tcl_Obj *fileName;                  /* Name of file to open. */
    int mode;                           /* POSIX open mode. */

    int permissions;                    /* If the open involves creating a
					 * file, with what modes to create
					 * it? */
{
    TestReport("open",fileName, NULL);
    return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
				 mode, permissions);
}

static int
TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive results. */
    Tcl_Obj *resultPtr;		/* Directory separators to pass to TclDoGlob. */
    Tcl_Obj *dirPtr;	        /* Contains path to directory to search. */
5733
5734
5735
5736
5737
5738
5739
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
TestReportChdir(dirName)
    Tcl_Obj *dirName;
{
    TestReport("chdir",dirName,NULL);
    return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
TestReportLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, 
		   clientDataPtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *fileName;		/* 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. */
    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. */
{
    TestReport("loadfile",fileName,NULL);
    return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), sym1, sym2,
			  proc1Ptr, proc2Ptr, clientDataPtr, unloadProcPtr);
}
static Tcl_Obj *
TestReportLink(path, to)
    Tcl_Obj *path;		/* Path of file to readlink or link */
    Tcl_Obj *to;		/* Path of file to link to, or NULL */

{
    TestReport("link",path,NULL);
    return Tcl_FSLink(TestReportGetNativePath(path),NULL);
}
static int
TestReportRenameFile(src, dst)
    Tcl_Obj *src;		/* Pathname of file or dir to be renamed
				 * (UTF-8). */
    Tcl_Obj *dst;		/* New pathname of file or directory
				 * (UTF-8). */







|
|



<
<
<
<
<
|








|
|


|


>

|
|







5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833





5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
TestReportChdir(dirName)
    Tcl_Obj *dirName;
{
    TestReport("chdir",dirName,NULL);
    return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
TestReportLoadFile(interp, fileName,  
		   handlePtr, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *fileName;		/* Name of the file containing the desired
				 * code. */





    Tcl_LoadHandle *handlePtr;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    TestReport("loadfile",fileName,NULL);
    return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
			  NULL, NULL, handlePtr, unloadProcPtr);
}
static Tcl_Obj *
TestReportLink(path, to, linkType)
    Tcl_Obj *path;		/* Path of file to readlink or link */
    Tcl_Obj *to;		/* Path of file to link to, or NULL */
    int linkType;
{
    TestReport("link",path,to);
    return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
}
static int
TestReportRenameFile(src, dst)
    Tcl_Obj *src;		/* Pathname of file or dir to be renamed
				 * (UTF-8). */
    Tcl_Obj *dst;		/* New pathname of file or directory
				 * (UTF-8). */
Changes to generic/tclUtf.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclUtf.c --
 *
 *	Routines for manipulating UTF-8 strings.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUtf.c,v 1.17.4.2 2002/06/10 05:33:13 wolfsuit Exp $
 */

#include "tclInt.h"

/*
 * Include the static character classification tables and macros.
 */










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclUtf.c --
 *
 *	Routines for manipulating UTF-8 strings.
 *
 * Copyright (c) 1997-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUtf.c,v 1.17.4.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"

/*
 * Include the static character classification tables and macros.
 */
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

#define UNICODE_SELF	0x80

/*
 * The following structures are used when mapping between Unicode (UCS-2)
 * and UTF-8.
 */
 
CONST unsigned char totalBytes[256] = {
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,







|
|







57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

#define UNICODE_SELF	0x80

/*
 * The following structures are used when mapping between Unicode (UCS-2)
 * and UTF-8.
 */

static CONST unsigned char totalBytes[256] = {
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
774
775
776
777
778
779
780
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
    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. */
{
    register CONST char *p = src+1;
    Tcl_UniChar result;
    int count, n;
    char buf[TCL_UTF_MAX];

    if (dst == NULL) {
	dst = buf;
    }

    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':
            if (isxdigit(UCHAR(p[1]))) { /* INTL: digit */
                char *end;

                result = (unsigned char) strtoul(p+1, &end, 16);
                count = end - src;
            } else {
                count = 2;
                result = 'x';
            }
            break;
	case 'u':
	    result = 0;
	    for (count = 0; count < 4; count++) {
		p++;
		if (!isxdigit(UCHAR(*p))) { /* INTL: digit */
		    break;
		}
		n = *p - '0';
		if (n > 9) {
		    n = n + '0' + 10 - 'A';
		}
		if (n > 16) {
		    n = n + 'A' - 'a';
		}
		result = (result << 4) + n;
	    }
	    if (count == 0) {
		result = 'u';
	    }
	    count += 2;
	    break;
		    
        case '\n':
            do {
                p++;
            } while ((*p == ' ') || (*p == '\t'));
            result = ' ';
            count = p - src;
            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 (!isdigit(UCHAR(*p)) || (UCHAR(*p) >= '8')) { /* INTL: digit */
		    break;
		}
		count = 3;
		result = (unsigned char)((result << 3) + (*p - '0'));
		p++;
		if (!isdigit(UCHAR(*p)) || (UCHAR(*p) >= '8')) { /* INTL: digit */
		    break;
		}
		count = 4;
		result = (unsigned char)((result << 3) + (*p - '0'));
		break;
	    }
	    if (UCHAR(*p) < UNICODE_SELF) {
		result = *p;
		count = 2;
	    } else {
		/*
		 * We have to convert here because 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
		 */
		count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
	    }
	    break;
    }

    if (readPtr != NULL) {
	*readPtr = count;
    }
    return Tcl_UniCharToUtf((int) result, dst);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToUpper --
 *







<
<
<
<
|
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<

|

|







774
775
776
777
778
779
780




781



782











783






















784








785






786












787
































788









789



790
791
792
793
794
795
796
797
798
799
800
    CONST char *src;		/* Points to the backslash character of
				 * a backslash sequence. */
    int *readPtr;		/* Fill in with number of characters read
				 * from src, unless NULL. */
    char *dst;			/* Filled with the bytes represented by the
				 * backslash sequence. */
{




#define LINE_LENGTH 128



    int numRead;











    int result;































    result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);






    if (numRead == LINE_LENGTH) {












	/* We ate a whole line.  Pay the price of a strlen() */
































	result = TclParseBackslash(src, (int)strlen(src), &numRead, dst);









    }



    if (readPtr != NULL) {
	*readPtr = numRead;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UtfToUpper --
 *
Changes to generic/tclUtil.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclUtil.c --
 *
 *	This file contains utility procedures that are used by many Tcl
 *	commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.24.2.2 2002/06/10 05:33:13 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The following variable holds the full path name of the binary













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclUtil.c --
 *
 *	This file contains utility procedures that are used by many Tcl
 *	commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 *  RCS: @(#) $Id: tclUtil.c,v 1.24.2.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The following variable holds the full path name of the binary
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
 */

	/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *name1;		/* Name of variable. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    CONST char *value;
    char *end;
    int prec;








|







1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
 */

	/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *name1;		/* Name of variable. */
    CONST char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    CONST char *value;
    char *end;
    int prec;

2120
2121
2122
2123
2124
2125
2126
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
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, *end;





    if (length < 0) {
	length = (bytes? strlen(bytes) : 0);
    }
    end = (bytes + length);

    p = bytes;
    while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */
	p++;
    }
    if (p == end) {
	return 0;
    }
    
    if ((*p == '+') || (*p == '-')) {
	p++;
    }
    if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */
	return 0;
    }
    p++;
    while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */
	p++;
    }
    if (p == end) {
	return 1;
    }
    if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetIntForIndex --
 *







|

>
>
>
>

|

<


|
|

|
|

<

|

<
<
|
<
<
<
<
<
|
<
<
<
<
<







2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135

2136
2137
2138
2139
2140
2141
2142
2143

2144
2145
2146


2147





2148





2149
2150
2151
2152
2153
2154
2155
TclLooksLikeInt(bytes, length)
    register CONST char *bytes;	/* Points to first byte of the string. */
    int length;			/* Number of bytes in the string. If < 0
				 * bytes up to the first null byte are
				 * considered (if they may appear in an 
				 * integer). */
{
    register CONST char *p;

    if ((bytes == NULL) && (length > 0)) {
	Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
    }

    if (length < 0) {
        length = (bytes? strlen(bytes) : 0);
    }


    p = bytes;
    while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
	length--; p++;
    }
    if (length == 0) {
        return 0;
    }

    if ((*p == '+') || (*p == '-')) {
        p++; length--;
    }








    return (0 != TclParseInteger(p, length));





}

/*
 *----------------------------------------------------------------------
 *
 * TclGetIntForIndex --
 *
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
				 * "end" or an integer. */
    int endValue;		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */
    int *indexPtr;		/* Location filled in with an integer
				 * representing an index. */
{
    char *bytes;
    int length, offset;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt wideOffset;
#endif

    /*
     * If the object is already an integer, use it.
     */







|







2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
				 * "end" or an integer. */
    int endValue;		/* The value to be stored at "indexPtr" if
				 * "objPtr" holds "end". */
    int *indexPtr;		/* Location filled in with an integer
				 * representing an index. */
{
    char *bytes;
    int offset;
#ifndef TCL_WIDE_INT_IS_LONG
    Tcl_WideInt wideOffset;
#endif

    /*
     * If the object is already an integer, use it.
     */
2263
2264
2265
2266
2267
2268
2269
2270
2271






2272
2273
2274
2275
2276
2277
2278

#endif /* TCL_WIDE_INT_IS_LONG */
    } else {
	/*
	 * Report a parse error.
	 */

	if ((Interp *)interp != NULL) {
	    bytes = Tcl_GetStringFromObj(objPtr, &length);






	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be integer or end?-integer?",
				   (char *) NULL);
	    if (!strncmp(bytes, "end-", 3)) {
		bytes += 3;
	    }







|
|
>
>
>
>
>
>







2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274

#endif /* TCL_WIDE_INT_IS_LONG */
    } else {
	/*
	 * Report a parse error.
	 */

	if (interp != NULL) {
	    bytes = Tcl_GetString(objPtr);
	    /*
	     * The result might not be empty; this resets it which
	     * should be both a cheap operation, and of little problem
	     * because this is an error-generation path anyway.
	     */
	    Tcl_ResetResult(interp);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be integer or end?-integer?",
				   (char *) NULL);
	    if (!strncmp(bytes, "end-", 3)) {
		bytes += 3;
	    }
2361
2362
2363
2364
2365
2366
2367

2368
2369
2370
2371
2372
2373
2374

    /* Check for a string rep of the right form. */

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
	    (size_t)((length > 3) ? 3 : length)) != 0)) {
	if (interp != NULL) {

	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be end?-integer?",
				   (char*) NULL);
	}
	return TCL_ERROR;
    }







>







2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371

    /* Check for a string rep of the right form. */

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
	    (size_t)((length > 3) ? 3 : length)) != 0)) {
	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be end?-integer?",
				   (char*) NULL);
	}
	return TCL_ERROR;
    }
2386
2387
2388
2389
2390
2391
2392

2393
2394
2395
2396
2397
2398
2399
	}

    } else {
	/*
	 * Conversion failed.  Report the error.
	 */
	if (interp != NULL) {

	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be integer or end?-integer?",
				   (char *) NULL);
	}
	return TCL_ERROR;
    }







>







2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
	}

    } else {
	/*
	 * Conversion failed.  Report the error.
	 */
	if (interp != NULL) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
				   "bad index \"", bytes,
				   "\": must be integer or end?-integer?",
				   (char *) NULL);
	}
	return TCL_ERROR;
    }
Changes to generic/tclVar.c.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

33

34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65

























































66
67
68
69
70
71
72
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.38.2.2 2002/06/10 05:33:13 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a
 * variable access is denied.
 */

static char *noSuchVar =	"no such variable";
static char *isArray =		"variable is array";
static char *needArray =	"variable isn't array";
static char *noSuchElement =	"no such element in array";

static char *danglingElement =	"upvar refers to element in deleted array";

static char *danglingVar =     "upvar refers to variable in deleted namespace";
static char *badNamespace =	"parent namespace doesn't exist";
static char *missingName =	"missing variable name";
static char *isArrayElement =	"name refers to an element in an array";

/*
 * Forward references to procedures defined later in this file:
 */

static int		CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
			    Var *varPtr, char *part1, CONST char *part2,
			    int flags, int leaveErrMsg));
static void		CleanupVar _ANSI_ARGS_((Var *varPtr,
			    Var *arrayPtr));
static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void		DeleteArray _ANSI_ARGS_((Interp *iPtr,
			    char *arrayName, Var *varPtr, int flags));
static void		DisposeTraceResult _ANSI_ARGS_((int flags,
			    char *result));
static int		MakeUpvar _ANSI_ARGS_((
			    Interp *iPtr, CallFrame *framePtr,
			    char *otherP1, CONST char *otherP2, int otherFlags,
			    CONST char *myName, int myFlags));
static Var *		NewVar _ANSI_ARGS_((void));
static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,

			    Var *varPtr, char *varName, Tcl_Obj *handleObj));
static void		VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
			    char *part1, CONST char *part2, char *operation,
			    char *reason));
static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));


























































/*
 * 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
 *







|










|
|
|
|
>
|
>
|
|
|
|





|
|
|




|


|
|
|
|


>
|

|
|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.38.2.3 2002/08/20 20:25:26 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a
 * variable access is denied.
 */

static CONST char *noSuchVar =		"no such variable";
static CONST char *isArray =		"variable is array";
static CONST char *needArray =		"variable isn't array";
static CONST char *noSuchElement =	"no such element in array";
static CONST char *danglingElement =
				"upvar refers to element in deleted array";
static CONST char *danglingVar =	
				"upvar refers to variable in deleted namespace";
static CONST char *badNamespace =	"parent namespace doesn't exist";
static CONST char *missingName =	"missing variable name";
static CONST char *isArrayElement =	"name refers to an element in an array";

/*
 * Forward references to procedures defined later in this file:
 */

static int		CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
			    Var *varPtr, CONST char *part1, CONST char *part2,
			    int flags, CONST int leaveErrMsg));
static void		CleanupVar _ANSI_ARGS_((Var *varPtr,
			    Var *arrayPtr));
static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void		DeleteArray _ANSI_ARGS_((Interp *iPtr,
			    CONST char *arrayName, Var *varPtr, int flags));
static void		DisposeTraceResult _ANSI_ARGS_((int flags,
			    char *result));
static int              ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, 
                            CallFrame *framePtr, Tcl_Obj *otherP1Ptr, 
                            CONST char *otherP2, CONST int otherFlags,
		            CONST char *myName, CONST int myFlags, int index));
static Var *		NewVar _ANSI_ARGS_((void));
static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST Var *varPtr, CONST char *varName,
			    Tcl_Obj *handleObj));
static void		VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *part1, CONST char *part2,
			    CONST char *operation, CONST char *reason));
static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));


/*
 * Functions defined in this file that may be exported in the future
 * for use by the bytecode compiler and engine or to the public interface.
 */

Var *		TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
		    CONST char *varName, int flags, CONST int create,
		    CONST char **errMsgPtr, int *indexPtr));
int		TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *part1Ptr, CONST char *part2, int flags));

static Tcl_FreeInternalRepProc FreeLocalVarName;
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_UpdateStringProc UpdateLocalVarName;
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
static Tcl_UpdateStringProc UpdateParsedVarName;

/*
 * Types of Tcl_Objs used to cache variable lookups.
 *
 * 
 * localVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the corresponding Proc 
 *   twoPtrValue.ptr2 = index into locals table
 *
 * nsVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1: pointer to the namespace containing the 
 *                     reference
 *   twoPtrValue.ptr2: pointer to the corresponding Var 
 *
 * parsedVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, 
 *                      or NULL if it is a scalar variable
 *   twoPtrValue.ptr2 = pointer to the element name string
 *                      (owned by this Tcl_Obj), or NULL if 
 *                      it is a scalar variable
 */

Tcl_ObjType tclLocalVarNameType = {
    "localVarName",
    FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
};

Tcl_ObjType tclNsVarNameType = {
    "namespaceVarName",
    FreeNsVarName, DupNsVarName, NULL, NULL
};

Tcl_ObjType tclParsedVarNameType = {
    "parsedVarName",
    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
};

/*
 * Type of Tcl_Objs used to speed up array searches.
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
 *   twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
 *
81
82
83
84
85
86
87
88
89




90
91
92
93
94
95
96


/*
 *----------------------------------------------------------------------
 *
 * TclLookupVar --
 *
 *	This procedure is used by virtually all of the variable code to
 *	locate a variable given its name(s).




 *
 * 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







<
|
>
>
>
>







141
142
143
144
145
146
147

148
149
150
151
152
153
154
155
156
157
158
159


/*
 *----------------------------------------------------------------------
 *
 * TclLookupVar --
 *

 *	This procedure is used to locate a variable given its name(s). It
 *      has been mostly superseded by TclObjLookupVar, it is now only used 
 *      by the string-based interfaces. It is kept in tcl8.4 mainly because 
 *      it is in the internal stubs table, so that some extension may be 
 *      calling it. 
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1 and part2, or NULL if the variable couldn't be found. If the
 *	variable is found, *arrayPtrPtr is filled in with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
111
112
113
114
115
116
117
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
 *
 * 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. */
    register 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. */
    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. */
{
    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. */
    CONST char *elName;		/* Name of array element or NULL; may be
				 * same as part2, or may be openParen+1. */
    char *openParen, *closeParen;
                                /* If this procedure parses a name into
				 * array and index, these point to the
				 * parens around the index.  Otherwise they
				 * are NULL. These are needed to restore
				 * the parens after parsing the name. */
    Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
    ResolverScheme *resPtr;
    Tcl_HashEntry *hPtr;
    register char *p;

    int new, i, result;




    varPtr = NULL;
    *arrayPtrPtr = NULL;
    openParen = closeParen = NULL;
    varNsPtr = NULL;		/* set non-NULL if a nonlocal variable */

    /*
     * 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;
	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p == ')') {
		if (part2 != NULL) {







		    openParen = NULL;























































































































































































































		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, part2, msg, needArray);
		    }















































		    goto done;




		}




		closeParen = p;








		*openParen = 0;



		*closeParen = 0;




		elName = openParen+1;





































	    } else {
		openParen = NULL;



	    }







	    break;








































	}




























    }




    /*
     * 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 || iPtr->varFramePtr == NULL) {
        cxtNsPtr = iPtr->globalNsPtr;
    } else {
        cxtNsPtr = iPtr->varFramePtr->nsPtr;
    }

    if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
        resPtr = iPtr->resolverPtr;

        if (cxtNsPtr->varResProc) {
            result = (*cxtNsPtr->varResProc)(interp, part1,
		    (Tcl_Namespace *) cxtNsPtr, flags, &var);
        } else {
            result = TCL_CONTINUE;
        }

        while (result == TCL_CONTINUE && resPtr) {
            if (resPtr->varResProc) {
                result = (*resPtr->varResProc)(interp, part1,
			(Tcl_Namespace *) cxtNsPtr, flags, &var);
            }
            resPtr = resPtr->nextPtr;
        }

        if (result == TCL_OK) {
            varPtr = (Var *) var;
            goto lookupVarPart2;
        } else if (result != TCL_CONTINUE) {
	    varPtr = (Var *) NULL;
	    /* can't just return here as input string is in an
	     * inconsistent state... */
	    goto done;
        }
    }

    /*
     * Look up part1. Look it up as either a namespace variable or as a
     * local variable in a procedure call frame (varFramePtr).
     * Interpret part1 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 part1 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 createPart1 and the variable isn't found, create the variable and,
     * if necessary, create varFramePtr's local var hashtable.
     */

    if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
	    || (varFramePtr == NULL)
	    || !varFramePtr->isProcCallFrame
	    || (strstr(part1, "::") != NULL)) {
	CONST char *tail;

	










	/*
	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
	 * or otherwise generate our own error!
	 */
	var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL,
		flags & ~TCL_LEAVE_ERR_MSG);
	if (var != (Tcl_Var) NULL) {
            varPtr = (Var *) var;
        }
	if (varPtr == NULL) {
	    if (createPart1) {   /* var wasn't found so create it  */
		TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL,
			flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);

		if (varNsPtr == NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, elName, msg, badNamespace);

		    }
		    goto done;
		}
		if (tail == NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, elName, msg, missingName);
		    }
		    goto done;

		}
		hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = varNsPtr;







	    } else {		/* var wasn't found and not to create it */
		if (flags & TCL_LEAVE_ERR_MSG) {
		    VarErrMsg(interp, part1, elName, msg, noSuchVar);

		}
		goto done;



	    }
	}
    } else {			/* local var: look in frame varFramePtr */
	Proc *procPtr = varFramePtr->procPtr;
	int localCt = procPtr->numCompiledLocals;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	Var *localVarPtr = varFramePtr->compiledLocals;
	int part1Len = strlen(part1);
	
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		register char *localName = localVarPtr->name;
		if ((part1[0] == localName[0])
		        && (part1Len == localPtr->nameLength)
		        && (strcmp(part1, localName) == 0)) {

		    varPtr = localVarPtr;
		    break;
		}
	    }
	    localVarPtr++;
	    localPtr = localPtr->nextPtr;
	}
	if (varPtr == NULL) {	/* look in the frame's var hash table */
	    tablePtr = varFramePtr->varTablePtr;
	    if (createPart1) {
		if (tablePtr == NULL) {
		    tablePtr = (Tcl_HashTable *)
			ckalloc(sizeof(Tcl_HashTable));
		    Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
		    varFramePtr->varTablePtr = tablePtr;
		}
		hPtr = Tcl_CreateHashEntry(tablePtr, part1, &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, part1);
		}
		if (hPtr == NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, elName, msg, noSuchVar);

		    }
		    goto done;
		}
		varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }

	}
    }





























    lookupVarPart2:
    /*
     * If varPtr is a link variable, we have a reference to some variable
     * that was created through an "upvar" or "global" command. Traverse
     * through any links until we find the referenced variable.



     */
	
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    /*












     * If we're not dealing with an array element, return varPtr.
     */


    
    if (elName == NULL) {

        goto done;
    }


    /*
     * 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(varPtr) && !TclIsVarArrayElement(varPtr)) {
	if (!createPart1) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, elName, msg, noSuchVar);
	    }
	    varPtr = NULL;
	    goto done;
	}

	/*
	 * Make sure we are not resurrecting a namespace variable from a
	 * deleted namespace!
	 */
	if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, elName, msg, danglingVar);
	    }
	    varPtr = NULL;
	    goto done;
	}

	TclSetVarArray(varPtr);
	TclClearVarUndefined(varPtr);
	varPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
    } else if (!TclIsVarArray(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, elName, msg, needArray);
	}
	varPtr = NULL;
	goto done;
    }
    *arrayPtrPtr = varPtr;
    if (createPart2) {
	hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new);
	if (new) {
	    if (varPtr->searchPtr != NULL) {
		DeleteSearches(varPtr);
	    }
	    varPtr = NewVar();
	    Tcl_SetHashValue(hPtr, varPtr);
	    varPtr->hPtr = hPtr;
	    varPtr->nsPtr = varNsPtr;
	    TclSetVarArrayElement(varPtr);
	}
    } else {
	hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName);
	if (hPtr == NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, elName, msg, noSuchElement);
	    }
	    varPtr = NULL;
	    goto done;
	}
    }
    varPtr = (Var *) Tcl_GetHashValue(hPtr);

    done:
    if (openParen != NULL) {
        *openParen = '(';
	*closeParen = ')';
    }
    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar --
 *







<




|






|













<
<
<
<
<
<
<
<
<
|
<


|

|
|
<
|
<
<
<
|
>
|
>
>
>



|
<














|






>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>







|









|







|







|

|
<
<
<




|

|





|



|






|

>

>
>
>
>
>
>
>
>
>
>




|





|
|

<

<
|
>
|
<
<

<
|
<
<
>






>
>
>
>
>
>
>
|
<
<
>

<
>
>
>







|




|
|
|
>
|
<





<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
>
|
|
|
<
|
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|
|
|
<
>
>
>
|
|
|
<
<
|
<
>
>
>
>
>
>
>
>
>
>
>
>
|
<
>
>
|
<
>
|
<
>






|
|

|

|
<






|

|

|
<


|
|
|

|
|

|

|
<

|
|
|

|
|




|



|


|

|
<


|
<
<
<
<
<
<
<







174
175
176
177
178
179
180

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205









206

207
208
209
210
211
212

213



214
215
216
217
218
219
220
221
222
223

224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706



707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756

757

758
759
760


761

762


763
764
765
766
767
768
769
770
771
772
773
774
775
776
777


778
779

780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799

800
801
802
803
804

805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827

828
829
830
831
832

833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865

866
867
868

869
870
871
872
873
874


875

876
877
878
879
880
881
882
883
884
885
886
887
888

889
890
891

892
893

894
895
896
897
898
899
900
901
902
903
904
905
906

907
908
909
910
911
912
913
914
915
916
917

918
919
920
921
922
923
924
925
926
927
928
929

930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950

951
952
953







954
955
956
957
958
959
960
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
        arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *part1;	        /* If part2 isn't NULL, this is the name of
				 * an array. Otherwise, this
				 * is a full variable name that could
				 * include a parenthesized array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST char *msg;			/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    int createPart1;		/* If 1, create hash table entry for part 1
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    int createPart2;		/* If 1, create hash table entry for part 2
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    Var **arrayPtrPtr;		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise
				 * this is set to NULL. */
{









    Var *varPtr;

    CONST char *elName;		/* Name of array element or NULL; may be
				 * same as part2, or may be openParen+1. */
    int openParen, closeParen;
                                /* If this procedure parses a name into
				 * array and index, these are the offsets to 
				 * the parens around the index.  Otherwise 

				 * they are -1. */



    register CONST char *p;
    CONST char *errMsg = NULL;
    int index;
#define VAR_NAME_BUF_SIZE 26
    char buffer[VAR_NAME_BUF_SIZE];
    char *newVarName = buffer;

    varPtr = NULL;
    *arrayPtrPtr = NULL;
    openParen = closeParen = -1;


    /*
     * Parse part1 into array name and index.
     * Always check if part1 is an array element name and allow it only if
     * part2 is not given.   
     * (if one does not care about creating array elements that can't be used
     *  from tcl, and prefer slightly better performance, one can put
     *  the following in an   if (part2 == NULL) { ... } block and remove
     *  the part2's test and error reporting  or move that code in array set)
     */

    elName = part2;
    for (p = part1; *p ; p++) {
	if (*p == '(') {
	    openParen = p - part1;
	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p == ')') {
		if (part2 != NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, part2, msg, needArray);
		    }
		    return NULL;
		}
		closeParen = p - part1;
	    } else {
		openParen = -1;
	    }
	    break;
	}
    }
    if (openParen != -1) {
	if (closeParen >= VAR_NAME_BUF_SIZE) {
	    newVarName = ckalloc((unsigned int) (closeParen+1));
	}
	memcpy(newVarName, part1, (unsigned int) closeParen);
	newVarName[openParen] = '\0';
	newVarName[closeParen] = '\0';
	part1 = newVarName;
	elName = newVarName + openParen + 1;
    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, 
            createPart1, &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    VarErrMsg(interp, part1, elName, msg, errMsg);
	}
    } else {
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	if (elName != NULL) {
	    *arrayPtrPtr = varPtr;
	    varPtr = TclLookupArrayElement(interp, part1, elName, flags, 
		    msg, createPart1, createPart2, varPtr);
	}
    }
    if (newVarName != buffer) {
	ckfree(newVarName);
    }

    return varPtr;
	
#undef VAR_NAME_BUF_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjLookupVar --
 *
 *	This procedure is used by virtually all of the variable code to
 *	locate a variable given its name(s). The parsing into array/element
 *      components and (if possible) the lookup results are cached in 
 *      part1Ptr, which is converted to one of the varNameTypes.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1Ptr and part2, or NULL if the variable couldn't be found. If 
 *      the variable is found, *arrayPtrPtr is filled with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags. 
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if createPart1 or createPart2 are 1 (these only cause the hash
 *	table entry or array to be created). For example, the variable might
 *	be a global that has been unset but is still referenced by a
 *	procedure, or a variable that has been unset but it only being kept
 *	in existence (if VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *      The object part1Ptr is converted to one of tclLocalVarNameType, 
 *      tclNsVarNameType or tclParsedVarNameType and caches as much of the
 *      lookup as it can.
 *
 *----------------------------------------------------------------------
 */
Var *
TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
        arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    register Tcl_Obj *part1Ptr;	/* If part2 isn't NULL, this is the name 
				 * of an array. Otherwise, this is a full 
				 * variable name that could include a parenthesized 
				 * array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST char *msg;		/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    CONST int createPart1;	/* If 1, create hash table entry for part 1
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    CONST int createPart2;	/* If 1, create hash table entry for part 2
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    Var **arrayPtrPtr;		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise
				 * this is set to NULL. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    char *part1;
    int index, len1, len2;
    int parsed = 0;
    Tcl_Obj *objPtr;
    Tcl_ObjType *typePtr = part1Ptr->typePtr;
    CONST char *errMsg = NULL;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Namespace *nsPtr;

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the 
     * pre-parsed parts.
     */

    *arrayPtrPtr = NULL;
    if (typePtr == &tclParsedVarNameType) {
	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
	    if (part2 != NULL) {
		/*
		 * ERROR: part1Ptr is already an array element, cannot 
		 * specify a part2.
		 */

		if (flags & TCL_LEAVE_ERR_MSG) {
		    part1 = TclGetString(part1Ptr);
		    VarErrMsg(interp, part1, part2, msg, needArray);
		}
		return NULL;
	    }
	    part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
	    part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
	    typePtr = part1Ptr->typePtr;
	}
	parsed = 1;
    }
    part1 = Tcl_GetStringFromObj(part1Ptr, &len1);    

    nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
    if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
	goto doParse;
    }
    
    if (typePtr == &tclLocalVarNameType) {
	Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;
	int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;
	int useLocal;

	useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame
	        && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));
	if (useLocal && (procPtr == varFramePtr->procPtr)) {
	    /*
	     * part1Ptr points to an indexed local variable of the
	     * correct procedure: use the cached value.
	     */
	    
	    varPtr = &(varFramePtr->compiledLocals[localIndex]);
	    goto donePart1;
	}
	goto doneParsing;
    } else if (typePtr == &tclNsVarNameType) {
	Namespace *cachedNsPtr;
	int useGlobal, useReference;

	varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
	cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;
	useGlobal = (cachedNsPtr == iPtr->globalNsPtr) 
	    && ((flags & TCL_GLOBAL_ONLY) 
		|| ((*part1 == ':') && (*(part1+1) == ':'))
		|| (varFramePtr == NULL) 
		|| (!varFramePtr->isProcCallFrame 
		    && (nsPtr == iPtr->globalNsPtr)));
	useReference = useGlobal || ((cachedNsPtr == nsPtr) 
	        && ((flags & TCL_NAMESPACE_ONLY) 
		    || (varFramePtr && !varFramePtr->isProcCallFrame 
			&& !(flags & TCL_GLOBAL_ONLY)
			/* careful: an undefined ns variable could
			 * be hiding a valid global reference. */
			&& !(varPtr->flags & VAR_UNDEFINED))));
	if (useReference && (varPtr->hPtr != NULL)) {
	    /*
	     * A straight global or namespace reference, use it. It isn't 
	     * so simple to deal with 'implicit' namespace references, i.e., 
	     * those where the reference could be to either a namespace 
	     * or a global variable. Those we lookup again.
	     *
	     * If (varPtr->hPtr == NULL), this might be a reference to a
	     * variable in a deleted namespace, kept alive by e.g. part1Ptr.
	     * We could conceivably be so unlucky that a new namespace was
	     * created at the same address as the deleted one, so to be 
	     * safe we test for a valid hPtr.
	     */
	    goto donePart1;
	}
	goto doneParsing;
    }

    doParse:
    if (!parsed && (*(part1 + len1 - 1) == ')')) {
	/*
	 * part1Ptr is possibly an unparsed array element.
	 */
	register int i;
	char *newPart2;
	len2 = -1;
	for (i = 0; i < len1; i++) {
	    if (*(part1 + i) == '(') {
		if (part2 != NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, part2, msg, needArray);
		    }
		}			

		/*
		 * part1Ptr points to an array element; first copy 
		 * the element name to a new string part2.
		 */

		part2 = part1 + i + 1;
		len2 = len1 - i - 2;
		len1 = i;

		newPart2 = ckalloc((unsigned int) (len2+1));
		memcpy(newPart2, part2, (unsigned int) len2);
		*(newPart2+len2) = '\0';
		part2 = newPart2;

		/*
		 * Free the internal rep of the original part1Ptr, now
		 * renamed objPtr, and set it to tclParsedVarNameType.
		 */

		objPtr = part1Ptr;
		if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
		    typePtr->freeIntRepProc(objPtr);
		}
		objPtr->typePtr = &tclParsedVarNameType;

		/*
		 * Define a new string object to hold the new part1Ptr, i.e., 
		 * the array name. Set the internal rep of objPtr, reset
		 * typePtr and part1 to contain the references to the
		 * array name.
		 */

		part1Ptr = Tcl_NewStringObj(part1, len1);
		Tcl_IncrRefCount(part1Ptr);

		objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
		objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;		

		typePtr = part1Ptr->typePtr;
		part1 = TclGetString(part1Ptr);
		break;
	    }
	}
    }
    
    doneParsing:
    /*
     * part1Ptr is not an array element; look it up, and convert 
     * it to one of the cached types if possible.
     */

    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	typePtr->freeIntRepProc(part1Ptr);
	part1Ptr->typePtr = NULL;
    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, 
            createPart1, &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    VarErrMsg(interp, part1, part2, msg, errMsg);
	}
	return NULL;
    }

    /*
     * Cache the newly found variable if possible.
     */

    if (index >= 0) {
        /*
	 * An indexed local variable.
	 */

	Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;

	part1Ptr->typePtr = &tclLocalVarNameType;
	procPtr->refCount++;
	part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
	part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
    } else if (index > -3) {
	Namespace *nsPtr;
    
	nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
	varPtr->refCount++;
	part1Ptr->typePtr = &tclNsVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
	part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */
	part1Ptr->typePtr = &tclParsedVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
	part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
    }
    
    donePart1:
#if 0
    if (varPtr == NULL) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    part1 = TclGetString(part1Ptr);
	    VarErrMsg(interp, part1, part2, msg, 
		    "Cached variable reference is NULL.");
	}
	return NULL;
    }
#endif
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    if (part2 != NULL) {
	/*
	 * Array element sought: look it up.
	 */

	part1 = TclGetString(part1Ptr);
	*arrayPtrPtr = varPtr;
	varPtr = TclLookupArrayElement(interp, part1, part2, 
                flags, msg, createPart1, createPart2, varPtr);
    }
    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupSimpleVar --
 *
 *	This procedure is used by to locate a simple variable (i.e., not
 *      an array element) given its name.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	varName, or NULL if the variable couldn't be found. If the variable 
 *      can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) 
 *      variable structure is created, entered into a hash table, and returned.
 *
 *      If the current CallFrame corresponds to a proc and the variable found is
 *      one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
 *      *indexPtr will be set to (according to the needs of TclObjLookupVar):
 *               -1 a global reference
 *               -2 a reference to a namespace variable
 *               -3 a non-cachable reference, i.e., one of:
 *                    . non-indexed local var
 *                    . a reference of unknown origin;
 *                    . resolution by a namespace or interp resolver
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and the corresponding error
 *	message is left in *errMsgPtr. 
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if create is 1 (this only causes the hash table entry to be
 *	created).  For example, the variable might be a global that has been
 *	unset but is still referenced by a procedure, or a variable that has
 *	been unset but it only being kept in existence (if VAR_UNDEFINED) by
 *	a trace.
 *
 * Side effects:
 *	A new hashtable entry may be created if create is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *varName;        /* This is a simple variable name that could
				 * representa scalar or an array. */
    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST int create;		/* If 1, create hash table entry for varname,
				 * if it doesn't already exist. If 0, return 
				 * error if it doesn't exist. */
    CONST char **errMsgPtr;
    int *indexPtr;
{    
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,
				 * unless an "uplevel" is executing. */
    Tcl_HashTable *tablePtr;	/* Points to the hashtable, if any, in which
				 * to look up the variable. */
    Tcl_Var var;                /* Used to search for global names. */
    Var *varPtr;		/* Points to the Var structure returned for
				 * the variable. */
    Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
    ResolverScheme *resPtr;
    Tcl_HashEntry *hPtr;
    int new, i, result;

    varPtr = NULL;
    varNsPtr = NULL;		/* set non-NULL if a nonlocal variable */
    *indexPtr = -3;

    /*
     * If this namespace has a variable resolver, then give it first
     * crack at the variable resolution.  It may return a Tcl_Var
     * value, it may signal to continue onward, or it may signal
     * an error.
     */
    if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
        cxtNsPtr = iPtr->globalNsPtr;
    } else {
        cxtNsPtr = iPtr->varFramePtr->nsPtr;
    }

    if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
        resPtr = iPtr->resolverPtr;

        if (cxtNsPtr->varResProc) {
            result = (*cxtNsPtr->varResProc)(interp, varName,
		    (Tcl_Namespace *) cxtNsPtr, flags, &var);
        } else {
            result = TCL_CONTINUE;
        }

        while (result == TCL_CONTINUE && resPtr) {
            if (resPtr->varResProc) {
                result = (*resPtr->varResProc)(interp, varName,
			(Tcl_Namespace *) cxtNsPtr, flags, &var);
            }
            resPtr = resPtr->nextPtr;
        }

        if (result == TCL_OK) {
            varPtr = (Var *) var;
	    return varPtr;
        } else if (result != TCL_CONTINUE) {
	    return NULL;



        }
    }

    /*
     * Look up varName. Look it up as either a namespace variable or as a
     * local variable in a procedure call frame (varFramePtr).
     * Interpret varName as a namespace variable if:
     *    1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
     *    2) there is no active frame (we're at the global :: scope),
     *    3) the active frame was pushed to define the namespace context
     *       for a "namespace eval" or "namespace inscope" command,
     *    4) the name has namespace qualifiers ("::"s).
     * Otherwise, if varName is a local variable, search first in the
     * frame's array of compiler-allocated local variables, then in its
     * hashtable for runtime-created local variables.
     *
     * If create and the variable isn't found, create the variable and,
     * if necessary, create varFramePtr's local var hashtable.
     */

    if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
	    || (varFramePtr == NULL)
	    || !varFramePtr->isProcCallFrame
	    || (strstr(varName, "::") != NULL)) {
	CONST char *tail;
	int lookGlobal;
	
	lookGlobal = (flags & TCL_GLOBAL_ONLY) 
	    || (cxtNsPtr == iPtr->globalNsPtr)
	    || ((*varName == ':') && (*(varName+1) == ':'));
	if (lookGlobal) {
	    *indexPtr = -1;
	    flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
	} else if (flags & TCL_NAMESPACE_ONLY) {
	    *indexPtr = -2;
	}

	/*
	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
	 * or otherwise generate our own error!
	 */
	var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
		flags & ~TCL_LEAVE_ERR_MSG);
	if (var != (Tcl_Var) NULL) {
            varPtr = (Var *) var;
        }
	if (varPtr == NULL) {
	    if (create) {   /* var wasn't found so create it  */
		TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
			flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);

		if (varNsPtr == NULL) {

		    *errMsgPtr = badNamespace;
		    return NULL;
		}


		if (tail == NULL) {

		    *errMsgPtr = missingName;


		    return NULL;
		}
		hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = varNsPtr;
		if ((lookGlobal)  || (varNsPtr == NULL)) {
		    /*
		     * The variable was created starting from the global
		     * namespace: a global reference is returned even if 
		     * it wasn't explicitly requested.
		     */
		    *indexPtr = -1;
		} else {


		    *indexPtr = -2;
		}

	    } else {		/* var wasn't found and not to create it */
		*errMsgPtr = noSuchVar;
		return NULL;
	    }
	}
    } else {			/* local var: look in frame varFramePtr */
	Proc *procPtr = varFramePtr->procPtr;
	int localCt = procPtr->numCompiledLocals;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	Var *localVarPtr = varFramePtr->compiledLocals;
	int varNameLen = strlen(varName);
	
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		register char *localName = localVarPtr->name;
		if ((varName[0] == localName[0])
		        && (varNameLen == localPtr->nameLength)
		        && (strcmp(varName, localName) == 0)) {
		    *indexPtr = i;
		    return localVarPtr;

		}
	    }
	    localVarPtr++;
	    localPtr = localPtr->nextPtr;
	}

	tablePtr = varFramePtr->varTablePtr;
	if (create) {
	    if (tablePtr == NULL) {
		tablePtr = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
		Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
		varFramePtr->varTablePtr = tablePtr;
	    }
	    hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
	    if (new) {
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = NULL; /* a local variable */
	    } else {
		varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }
	} else {
	    hPtr = NULL;
	    if (tablePtr != NULL) {
		hPtr = Tcl_FindHashEntry(tablePtr, varName);
	    }
	    if (hPtr == NULL) {

		*errMsgPtr = noSuchVar;
		return NULL;
	    }
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	}

    }
    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupArrayElement --
 *
 *	This procedure is used to locate a variable which is in an array's 
 *      hashtable given a pointer to the array's Var structure and the 
 *      element's name.
 *
 * Results:
 *	The return value is a pointer to the variable structure , or NULL if 
 *      the variable couldn't be found. 
 *
 *      If arrayPtr points to a variable that isn't an array and createPart1 
 *      is 1, the corresponding variable will be converted to an array. 
 *      Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *      If the variable is not found and createPart2 is 1, the variable is
 *      created. Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if createPart1 or createPart2 are 1 (these only cause the hash
 *	table entry or array to be created). For example, the variable might
 *	be a global that has been unset but is still referenced by a
 *	procedure, or a variable that has been unset but it only being kept
 *	in existence (if VAR_UNDEFINED) by a trace.
 *

 * Side effects:
 *      The variable at arrayPtr may be converted to be an array if 
 *      createPart1 is 1. A new hashtable entry may be created if createPart2 

 *      is 1.
 *
 *----------------------------------------------------------------------
 */

Var *


TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)

    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *arrayName;	        /* This is the name of the array. */
    CONST char *elName;		/* Name of element within array. */
    CONST int flags;		/* Only TCL_LEAVE_ERR_MSG bit matters. */
    CONST char *msg;			/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    CONST int createArray;	/* If 1, transform arrayName to be an array
				 * if it isn't one yet and the transformation 
				 * is possible. If 0, return error if it 
				 * isn't already an array. */
    CONST int createElem;	/* If 1, create hash table entry for the 
				 * element, if it doesn't already exist. If

				 * 0, return error if it doesn't exist. */
    Var *arrayPtr;	        /* Pointer to the array's Var structure. */
{

    Tcl_HashEntry *hPtr;
    int new;

    Var *varPtr;

    /*
     * We're dealing with an array element. Make sure the variable is an
     * array and look up the element (create the element if desired).
     */

    if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
	if (!createArray) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elName, msg, noSuchVar);
	    }
	    return NULL;

	}

	/*
	 * Make sure we are not resurrecting a namespace variable from a
	 * deleted namespace!
	 */
	if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elName, msg, danglingVar);
	    }
	    return NULL;

	}

	TclSetVarArray(arrayPtr);
	TclClearVarUndefined(arrayPtr);
	arrayPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
    } else if (!TclIsVarArray(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elName, msg, needArray);
	}
	return NULL;

    }

    if (createElem) {
	hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
	if (new) {
	    if (arrayPtr->searchPtr != NULL) {
		DeleteSearches(arrayPtr);
	    }
	    varPtr = NewVar();
	    Tcl_SetHashValue(hPtr, varPtr);
	    varPtr->hPtr = hPtr;
	    varPtr->nsPtr = arrayPtr->nsPtr;
	    TclSetVarArrayElement(varPtr);
	}
    } else {
	hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
	if (hPtr == NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elName, msg, noSuchElement);
	    }
	    return NULL;

	}
    }
    return (Var *) Tcl_GetHashValue(hPtr);







}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar --
 *
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    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);
}








|







975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
				 * bits. */
{
    return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}

511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533




















































534
535
536
537
538
539
540
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    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_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.







|















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
                                 * bits. */
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
    if (objPtr == NULL) {
	return NULL;
    }
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2Ex --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a
 *	two-part name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetVar2Ex(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;

    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */
    varPtr = TclLookupVar(interp, part1, part2, flags, "read",
            /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjGetVar2 --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a
 *	two-part name consisting of array name and element within array.
563
564
565
566
567
568
569

570
571
572
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
				 * name of a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG bits. */
{

    char *part1, *part2;

    part1 = Tcl_GetString(part1Ptr);
    if (part2Ptr != NULL) {
	part2 = Tcl_GetString(part2Ptr);
    } else {









	part2 = NULL;
    }
    
    return Tcl_GetVar2Ex(interp, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * 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. */



    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. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;
    Var *arrayPtr;
    char *msg;

    /*
     * 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;
    }

    /*
     * Invoke any traces that have been set for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
		(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
		| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto errorReturn;
	}
    }

    /*







>



<
|
|
>
>
>
>
>
>
>
>
>
|

|
|





|

|
<
>
>



|
|
|
<










|


>
>
>
|



|



<
<
|
<
<
<
<
<
<
<
<
<
<
<
<







|







1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124

1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147

1148
1149
1150
1151
1152
1153
1154
1155

1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179


1180












1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
				 * name of a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = Tcl_GetString(part1Ptr);

    part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
    
    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */
    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
            /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrGetVar --
 *
 *	Return the value of a Tcl variable as a Tcl object, given the

 *      pointers to the variable's (and possibly containing array's) 
 *      VAR structure.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by varPtr. If the specified variable doesn't exist, or if there 
 *      is a clash in array usage, then NULL is returned and a message will be 
 *      left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.

 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register Var *varPtr;       /* The variable to be read.*/
    Var *arrayPtr;              /* NULL for scalar variables, pointer to
				 * the containing array otherwise. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    CONST int flags;		/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits. */
{
    Interp *iPtr = (Interp *) interp;


    CONST char *msg;













    /*
     * Invoke any traces that have been set for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
		| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto errorReturn;
	}
    }

    /*
668
669
670
671
672
673
674
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
     * it, then free up the relevant structures and hash table entries.
     */

    errorReturn:
    if (TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, arrayPtr);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetIndexedScalar --
 *
 *	Return the Tcl object value of a local scalar variable in the active
 *	procedure, given its index in the procedure's array of compiler
 *	allocated local variables.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by localIndex. 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 if TCL_LEAVE_ERR_MSG is set in flags.
 *
 * 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 *
TclGetIndexedScalar(interp, localIndex, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register int localIndex;	/* Index of variable in procedure's array
				 * of local variables. */
    int flags;			/* TCL_LEAVE_ERR_MSG if to leave an error
				 * message in interpreter's result on an error.
				 * Otherwise no error message is left. */
{
    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. */
    Var *compiledLocals = varFramePtr->compiledLocals;
    register Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    char *varName;		/* Name of the local variable. */
    char *msg;

#ifdef TCL_COMPILE_DEBUG
    int localCt = varFramePtr->procPtr->numCompiledLocals;

    if (compiledLocals == NULL) {
	fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n",
		localIndex, (unsigned int) varFramePtr);
	panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",
		(unsigned int) varFramePtr);
    }
    if ((localIndex < 0) || (localIndex >= localCt)) {
	fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n",
		localIndex, (unsigned int) varFramePtr, localCt);
	panic("TclGetIndexedScalar: bad local index %i in frame 0x%x",
		localIndex, (unsigned int) varFramePtr);
    }
#endif /* TCL_COMPILE_DEBUG */
    
    varPtr = &(compiledLocals[localIndex]);
    varName = varPtr->name;

    /*
     * If varPtr is a link variable, we have a reference to some variable
     * that was created through an "upvar" or "global" command, or we have a
     * reference to a variable in an enclosing namespace. Traverse through
     * any links until we find the referenced variable.
     */
	
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    /*
     * Invoke any traces that have been set for the variable.
     */

    if (varPtr->tracePtr != NULL) {
	if (TCL_ERROR == CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName,
		NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    return NULL;
	}
    }

    /*
     * Make sure we're dealing with a scalar variable and not an array, and
     * that the variable exists (isn't undefined).
     */

    if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArray(varPtr)) {
		msg = isArray;
	    } else {
		msg = noSuchVar;
	    }
	    VarErrMsg(interp, varName, NULL, "read", msg);
	}
	return NULL;
    }
    return varPtr->value.objPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetElementOfIndexedArray --
 *
 *	Return the Tcl object value for an element in a local array
 *	variable. The element is named by the object elemPtr while the 
 *	array is specified by its index in the active procedure's array
 *	of compiler allocated local variables.
 *
 * Results:
 *	The return value points to the current object value of the
 *	element. If the specified array or element 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 if TCL_LEAVE_ERR_MSG is set in flags.
 *
 * 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 *
TclGetElementOfIndexedArray(interp, localIndex, elemPtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    int localIndex;		/* Index of array variable in procedure's
				 * array of local variables. */
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
				 * an element to get in the array. */
    int flags;			/* TCL_LEAVE_ERR_MSG if to leave an error
				 * message in interpreter's result on an error.
				 * Otherwise no error message is left. */
{
    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. */
    Var *compiledLocals = varFramePtr->compiledLocals;
    Var *arrayPtr;		/* Points to the array's in-frame Var
				 * structure. */
    char *arrayName;		/* Name of the local array. */
    Tcl_HashEntry *hPtr;
    Var *varPtr = NULL;		/* Points to the element's Var structure
				 * that we return. Initialized to avoid
				 * compiler warning. */
    char *elem, *msg;
    int new;

#ifdef TCL_COMPILE_DEBUG
    Proc *procPtr = varFramePtr->procPtr;
    int localCt = procPtr->numCompiledLocals;

    if (compiledLocals == NULL) {
	fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n",
		localIndex, (unsigned int) varFramePtr);
	panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",
		(unsigned int) varFramePtr);
    }
    if ((localIndex < 0) || (localIndex >= localCt)) {
	fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n",
		localIndex, (unsigned int) varFramePtr, localCt);
	panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x",
		localIndex, (unsigned int) varFramePtr);
    }
#endif /* TCL_COMPILE_DEBUG */

    elem = TclGetString(elemPtr);
    arrayPtr = &(compiledLocals[localIndex]);
    arrayName = arrayPtr->name;

    /*
     * If arrayPtr is a link variable, we have a reference to some variable
     * that was created through an "upvar" or "global" command, or we have a
     * reference to a variable in an enclosing namespace. Traverse through
     * any links until we find the referenced variable.
     */
	
    while (TclIsVarLink(arrayPtr)) {
	arrayPtr = arrayPtr->value.linkPtr;
    }

    /*
     * Make sure we're dealing with an array and that the array variable
     * exists (isn't undefined).
     */

    if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elem, "read", noSuchVar);
	}
	goto errorReturn;
    } 

    /*
     * Look up the element. Note that we must create the element (but leave
     * it marked undefined) if it does not already exist. This allows a
     * trace to create new array elements "on the fly" that did not exist
     * before. A trace is always passed a variable for the array element. If
     * the trace does not define the variable, it will be deleted below (at
     * errorReturn) and an error returned.
     */

    hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
    if (new) {
	if (arrayPtr->searchPtr != NULL) {
	    DeleteSearches(arrayPtr);
	}
	varPtr = NewVar();
	Tcl_SetHashValue(hPtr, varPtr);
	varPtr->hPtr = hPtr;
	varPtr->nsPtr = varFramePtr->nsPtr;
	TclSetVarArrayElement(varPtr);
    } else {
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
    }

    /*
     * Invoke any traces that have been set for the element variable.
     */

    if ((varPtr->tracePtr != NULL)
            || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
	        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 (TclIsVarArray(varPtr)) {
	    msg = isArray;
	} else {
	    msg = noSuchVar;
	}
	VarErrMsg(interp, arrayName, elem, "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 ((varPtr != NULL) && TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, NULL); /* the array is not in a hashtable */
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjCmd --







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1217
1218
1219
1220
1221
1222
1223














































































































































































































































































1224
1225
1226
1227
1228
1229
1230
     * it, then free up the relevant structures and hash table entries.
     */

    errorReturn:
    if (TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, arrayPtr);
    }














































































































































































































































































    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetObjCmd --
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    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);







|







1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    CONST char *newValue;	/* New value for varName. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
    Tcl_Interp *interp;         /* Command interpreter in which variable is
                                 * to be looked up. */
    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,







|







1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
    Tcl_Interp *interp;         /* Command interpreter in which variable is
                                 * to be looked up. */
    CONST char *part1;          /* If part2 is NULL, this is name of scalar
                                 * variable. Otherwise it is the name of
                                 * an array. */
    CONST char *part2;		/* Name of an element within an array, or
				 * NULL. */
    CONST char *newValue;       /* New value for variable. */
    int flags;                  /* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
1089
1090
1091
1092
1093
1094
1095
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
    Tcl_DecrRefCount(valuePtr); /* done with the object */
    
    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjSetVar2 --
 *
 *	This function is the same as Tcl_SetVar2Ex below, 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. */
{
    char *part1, *part2;

    part1 = Tcl_GetString(part1Ptr);
    if (part2Ptr != NULL) {
	part2 = Tcl_GetString(part2Ptr);
    } else {
	part2 = NULL;
    }
    
    return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2Ex --
 *
 *	Given a two-part variable name, which may refer either to a scalar







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1368
1369
1370
1371
1372
1373
1374





















































1375
1376
1377
1378
1379
1380
1381
    Tcl_DecrRefCount(valuePtr); /* done with the object */
    
    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}






















































/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2Ex --
 *
 *	Given a two-part variable name, which may refer either to a scalar
1185
1186
1187
1188
1189
1190
1191
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
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    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. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;
    Var *arrayPtr;
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;
    int result;

    varPtr = TclLookupVar(interp, part1, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }











































































































    /*
     * 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).







|









<
|
<
<
<
<






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427

1428




1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{

    Var *varPtr, *arrayPtr;





    varPtr = TclLookupVar(interp, part1, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, 
            newValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjSetVar2 --
 *
 *	This function is the same as Tcl_SetVar2Ex above, except the
 *	variable names are passed in Tcl object instead of strings.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if
 *	the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
 *	be left in the interpreter's result. Note that the returned object
 *	may not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    register Tcl_Obj *part1Ptr;	/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));    

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, 
            newValuePtr, flags);
}


/*
 *----------------------------------------------------------------------
 *
 * TclPtrSetVar --
 *
 *	This function is the same as Tcl_SetVar2Ex above, except that
 *      it requires pointers to the variable's Var structs in addition
 *	to the variable names.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the write operation was disallowed because an array was
 *	expected but not found (or vice versa), then NULL is returned; if
 *	the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
 *	be left in the interpreter's result. Note that the returned object
 *	may not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.

 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Name of an array (if part2 is non-NULL)
				 * or the name of a variable. */
    CONST char *part2;		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    CONST int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;
    int result;

    /*
     * If the variable is in a hashtable and its hPtr field is NULL, then we
     * may have an upvar to an array element where the array was deleted
     * or an upvar to a namespace variable whose namespace was deleted.
     * Generate an error (allowing the variable to be reset would screw up
     * our storage allocation and is meaningless anyway).
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250








1251
1252
1253
1254
1255
1256
1257
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, part2, "set", isArray);
	}
	return NULL;
    }

    /*
     * At this point, if we were appending, we used to call read traces: we
     * treated append as a read-modify-write. However, it seemed unlikely to
     * us that a real program would be interested in such reads being done
     * during a set operation.
     */









    /*
     * 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".







|
|
<
<

>
>
>
>
>
>
>
>







1566
1567
1568
1569
1570
1571
1572
1573
1574


1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, part2, "set", isArray);
	}
	return NULL;
    }

    /*
     * Invoke any read traces that have been set for the variable if it
     * is requested; this is only done in the core when lappending.


     */

    if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) 
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
	if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
		TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    return NULL;
	}
    }

    /*
     * Set the variable's new value. If appending, append the new value to
     * the variable, either as a list element or as a string. Also, if
     * appending, then if the variable's old value is unshared we can modify
     * it directly, otherwise we must create a new copy to modify: this is
     * "copy on write".
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332

    /*
     * Invoke any write traces for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
	        (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto cleanup;
	}
    }

    /*







|







1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665

    /*
     * Invoke any write traces for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
	        (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto cleanup;
	}
    }

    /*
1351
1352
1353
1354
1355
1356
1357
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
     * free up the relevant structures and hash table entries.
     */

    cleanup:
    if (TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, arrayPtr);
    }
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetIndexedScalar --
 *
 *	Change the Tcl object value of a local scalar variable in the active
 *	procedure, given its compile-time allocated index in the procedure's
 *	array of local variables.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable given by localIndex. 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 if flags has TCL_LEAVE_ERR_MSG.
 *	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. The reference count is
 *	decremented for any old value of the variable and incremented for
 *	its new value. If as a result of a variable trace the new value for
 *	the variable is not the same one referenced by newValuePtr, then
 *	newValuePtr's ref count is left unchanged. 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. This procedure does not create
 *	new variables, but only sets those recognized at compile time.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclSetIndexedScalar(interp, localIndex, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    int localIndex;		/* Index of variable in procedure's array
				 * of local variables. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
    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. */
    Var *compiledLocals = varFramePtr->compiledLocals;
    register Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    char *varName;		/* Name of the local variable. */
    Tcl_Obj *oldValuePtr;
    Tcl_Obj *resultPtr = NULL;

#ifdef TCL_COMPILE_DEBUG
    Proc *procPtr = varFramePtr->procPtr;
    int localCt = procPtr->numCompiledLocals;

    if (compiledLocals == NULL) {
	fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n",
		localIndex, (unsigned int) varFramePtr);
	panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
		(unsigned int) varFramePtr);
    }
    if ((localIndex < 0) || (localIndex >= localCt)) {
	fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n",
		localIndex, (unsigned int) varFramePtr, localCt);
	panic("TclSetIndexedScalar: bad local index %i in frame 0x%x",
		localIndex, (unsigned int) varFramePtr);
    }
#endif /* TCL_COMPILE_DEBUG */
    
    varPtr = &(compiledLocals[localIndex]);
    varName = varPtr->name;

    /*
     * If varPtr is a link variable, we have a reference to some variable
     * that was created through an "upvar" or "global" command, or we have a
     * reference to a variable in an enclosing namespace. Traverse through
     * any links until we find the referenced variable.
     */
	
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    /*
     * Invoke any read traces that have been set for the variable if we
     * are appending, but only in the lappend case.
     */

    if ((flags & TCL_APPEND_VALUE) && (flags & TCL_LIST_ELEMENT)
	    && (varPtr->tracePtr != NULL)) {
	if (TCL_ERROR == CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName,
		NULL, TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    return NULL;
	}
    }

    /*
     * 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)) {
		VarErrMsg(interp, varName, NULL, "set", danglingElement);
	    } else {
		VarErrMsg(interp, varName, NULL, "set", danglingVar);
	    }
	}
	return NULL;
    }

    /*
     * It's an error to try to set an array variable itself.
     */

    if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, varName, NULL, "set", isArray);
	}
	return NULL;
    }

    /*
     * Set the variable's new value and discard its old value.
     */

    oldValuePtr = varPtr->value.objPtr;
    if (flags & TCL_APPEND_VALUE) {
	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
	    varPtr->value.objPtr = NULL;
	    oldValuePtr = NULL;
	}
	if (flags & TCL_LIST_ELEMENT) {	/* append list element */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		Tcl_DecrRefCount(oldValuePtr);
		oldValuePtr = varPtr->value.objPtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    }
	    if (Tcl_ListObjAppendElement(interp, oldValuePtr,
		    newValuePtr) != 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) {        /* set new value */
	/*
	 * 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 to obj */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);    /* discard old value */
	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);

    /*
     * Invoke any write traces for the variable.
     */

    if (varPtr->tracePtr != NULL) {
	if (TCL_ERROR == CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName,
		NULL, 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 it was changed is a gross way, just return an empty string
     * object.
     */

    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }
    
    resultPtr = Tcl_NewObj();

    /*
     * 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)) {
	CleanupVar(varPtr, NULL);
    }
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclSetElementOfIndexedArray --
 *
 *	Change the Tcl object value of an element in a local array
 *	variable. The element is named by the object elemPtr while the array
 *	is specified by its index in the active procedure's array of
 *	compiler allocated local variables.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	element. If the specified array or element 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 if flags has TCL_LEAVE_ERR_MSG. 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 array element is set. The reference count is
 *	decremented for any old value of the element and incremented for its
 *	new value. If as a result of a variable trace the new value for the
 *	element is not the same one referenced by newValuePtr, then
 *	newValuePtr's ref count is left unchanged. 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. This procedure will not create new
 *	array variables, but only sets elements of those arrays recognized
 *	at compile time. However, if the entry doesn't exist then a new
 *	variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which the array is
				 * to be found. */
    int localIndex;		/* Index of array variable in procedure's
				 * array of local variables. */
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
				 * an element to set in the array. */
    Tcl_Obj *newValuePtr;	/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
    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. */
    Var *compiledLocals = varFramePtr->compiledLocals;
    Var *arrayPtr;		/* Points to the array's in-frame Var
				 * structure. */
    char *arrayName;		/* Name of the local array. */
    char *elem;
    Tcl_HashEntry *hPtr;
    Var *varPtr = NULL;		/* Points to the element's Var structure
				 * that we return. */
    Tcl_Obj *resultPtr = NULL;
    Tcl_Obj *oldValuePtr;
    int new;
    
#ifdef TCL_COMPILE_DEBUG
    Proc *procPtr = varFramePtr->procPtr;
    int localCt = procPtr->numCompiledLocals;

    if (compiledLocals == NULL) {
	fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n",
		localIndex, (unsigned int) varFramePtr);
	panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
		(unsigned int) varFramePtr);
    }
    if ((localIndex < 0) || (localIndex >= localCt)) {
	fprintf(stderr, "\nTclSetIndexedScalar: can't set element of local %i in frame 0x%x with %i locals\n",
		localIndex, (unsigned int) varFramePtr, localCt);
	panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",
		localIndex, (unsigned int) varFramePtr);
    }
#endif /* TCL_COMPILE_DEBUG */

    elem = TclGetString(elemPtr);
    arrayPtr = &(compiledLocals[localIndex]);
    arrayName = arrayPtr->name;

    /*
     * If arrayPtr is a link variable, we have a reference to some variable
     * that was created through an "upvar" or "global" command, or we have a
     * reference to a variable in an enclosing namespace. Traverse through
     * any links until we find the referenced variable.
     */

    while (TclIsVarLink(arrayPtr)) {
	arrayPtr = arrayPtr->value.linkPtr;
    }

    /*
     * 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 ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    if (TclIsVarArrayElement(arrayPtr)) {
		VarErrMsg(interp, arrayName, elem, "set", danglingElement);
	    } else {
		VarErrMsg(interp, arrayName, elem, "set", danglingVar);
	    }
	}
	goto errorReturn;
    }

    /*
     * Make sure we're dealing with an array.
     */

    if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
	TclSetVarArray(arrayPtr);
	arrayPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
	TclClearVarUndefined(arrayPtr);
    } else if (!TclIsVarArray(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elem, "set", needArray);
	}
	goto errorReturn;
    }

    /*
     * Look up the element.
     */

    hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
    if (new) {
	if (arrayPtr->searchPtr != NULL) {
	    DeleteSearches(arrayPtr);
	}
	varPtr = NewVar();
	Tcl_SetHashValue(hPtr, varPtr);
	varPtr->hPtr = hPtr;
        varPtr->nsPtr = varFramePtr->nsPtr;
	TclSetVarArrayElement(varPtr);
    }
    varPtr = (Var *) Tcl_GetHashValue(hPtr);

    /*
     * It's an error to try to set an array variable itself.
     */

    if (TclIsVarArray(varPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elem, "set", isArray);
	}
	goto errorReturn;
    }

    /*
     * Invoke any read traces that have been set for the element variable if
     * we are appending, but only in the lappend case.
     */

    if ((flags & TCL_APPEND_VALUE) && (flags & TCL_LIST_ELEMENT)
	    && ((varPtr->tracePtr != NULL)
		    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
	if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
		TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto errorReturn;
	}
    }

    /*
     * Set the variable's new value and discard the old one.
     */

    oldValuePtr = varPtr->value.objPtr;
    if (flags & TCL_APPEND_VALUE) {
	if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
	    Tcl_DecrRefCount(oldValuePtr);     /* discard old value */
	    varPtr->value.objPtr = NULL;
	    oldValuePtr = NULL;
	}
	if (flags & TCL_LIST_ELEMENT) {	/* append list element */
	    if (oldValuePtr == NULL) {
		TclNewObj(oldValuePtr);
		varPtr->value.objPtr = oldValuePtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    } else if (Tcl_IsShared(oldValuePtr)) {
		varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
		Tcl_DecrRefCount(oldValuePtr);
		oldValuePtr = varPtr->value.objPtr;
		Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
	    }
	    if (Tcl_ListObjAppendElement(interp, oldValuePtr,
		    newValuePtr) != 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) {	/* set new value */
	/*
	 * 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 to obj */
	if (oldValuePtr != NULL) {
	    TclDecrRefCount(oldValuePtr);	/* discard old value */
	}
    }
    TclSetVarScalar(varPtr);
    TclClearVarUndefined(varPtr);

    /*
     * Invoke any write traces for the element variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	if (TCL_ERROR == CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
		TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
	    goto errorReturn;
	}
    }

    /*
     * Return the element's value unless it was changed in some gross way by
     * a trace (e.g. it was unset and then recreated as an array). If it was
     * changed is a gross way, just return an empty string object.
     */

    if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
	return varPtr->value.objPtr;
    }
    
    resultPtr = Tcl_NewObj();

    /*
     * 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 ((varPtr != NULL) && TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */
    }
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrVar2 --







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1684
1685
1686
1687
1688
1689
1690



















































































































































































































































































































































































































































































































1691
1692
1693
1694
1695
1696
1697
     * free up the relevant structures and hash table entries.
     */

    cleanup:
    if (TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, arrayPtr);
    }



















































































































































































































































































































































































































































































































    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrVar2 --
1895
1896
1897
1898
1899
1900
1901





























































1902
1903
1904
1905
1906
1907

1908
1909
1910
1911
1912
1913
1914
1915
				 * part1Ptr. */
    long incrAmount;		/* Amount to be added to variable. */
    int flags;                  /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{





























































    register Tcl_Obj *varValuePtr;
    int createdNewObj;		/* Set 1 if var's value object is shared
				 * so we must increment a copy (i.e. copy
				 * on write). */
    long i;


    varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>
|







1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
				 * part1Ptr. */
    long incrAmount;		/* Amount to be added to variable. */
    int flags;                  /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = TclGetString(part1Ptr);
    part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
	    0, 1, &arrayPtr);
    if (varPtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }
    return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2,
	    incrAmount, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrIncrVar --
 *
 *	Given the pointers to a variable and possible containing array, 
 *      increment the Tcl object value of the variable by a specified 
 *      amount.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable. If the specified variable doesn't exist, or there is a
 *	clash in array usage, or an error occurs while executing variable
 *	traces, then NULL is returned and a message will be left in
 *	the interpreter's result.
 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    Var *varPtr;
    Var *arrayPtr;
    CONST char *part1;		/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    CONST char *part2;		/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    CONST long incrAmount;	/* Amount to be added to variable. */
    CONST int flags;            /* Various flags that tell how to incr value:
				 * any of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
    register Tcl_Obj *varValuePtr;
    int createdNewObj;		/* Set 1 if var's value object is shared
				 * so we must increment a copy (i.e. copy
				 * on write). */
    long i;

    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);

    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
1959
1960
1961
1962
1963
1964
1965
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
    }
#endif

    /*
     * Store the variable's new value and run any write traces.
     */
    
    return Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrIndexedScalar --
 *
 *	Increments the Tcl object value of a local scalar variable in the
 *	active procedure, given its compile-time allocated index in the
 *	procedure's array of local variables.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	variable given by localIndex. 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. 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 *
TclIncrIndexedScalar(interp, localIndex, incrAmount)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be found. */
    int localIndex;		/* Index of variable in procedure's array
				 * of local variables. */
    long incrAmount;		/* Amount to be added to variable. */
{
    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 = TclGetIndexedScalar(interp, localIndex, TCL_LEAVE_ERR_MSG);
    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
     * Reach into the object's representation to extract and 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)) {
	createdNewObj = 1;
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
    }
#ifdef TCL_WIDE_INT_IS_LONG
    if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) {
	if (createdNewObj) {
	    Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
	}
	return NULL;
    }
    Tcl_SetLongObj(varValuePtr, (i + incrAmount));
#else
    if (varValuePtr->typePtr == &tclWideIntType) {
	Tcl_WideInt wide = varValuePtr->internalRep.wideValue;
	Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
    } else if (varValuePtr->typePtr == &tclIntType) {
	i = varValuePtr->internalRep.longValue;
	Tcl_SetIntObj(varValuePtr, i + incrAmount);
    } else {
	/*
	 * Not an integer or wide internal-rep...
	 */
	Tcl_WideInt wide;
	if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
	    if (createdNewObj) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
	    }
	    return NULL;
	}
	if (wide <= Tcl_LongAsWide(LONG_MAX)
		&& wide >= Tcl_LongAsWide(LONG_MIN)) {
	    Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
	} else {
	    Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
	}
    }
#endif

    /*
     * Store the variable's new value and run any write traces.
     */
    
    return TclSetIndexedScalar(interp, localIndex, varValuePtr,
	    TCL_LEAVE_ERR_MSG);
}

/*
 *----------------------------------------------------------------------
 *
 * TclIncrElementOfIndexedArray --
 *
 *	Increments the Tcl object value of an element in a local array
 *	variable. The element is named by the object elemPtr while the array
 *	is specified by its index in the active procedure's array of
 *	compiler allocated local variables.
 *
 * Results:
 *	Returns a pointer to the Tcl_Obj holding the new value of the
 *	element. If the specified array or element 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 array element is incremented by the specified
 *	amount. 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. If the
 *	entry doesn't exist then a new variable is created.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
    Tcl_Interp *interp;		/* Command interpreter in which the array is
				 * to be found. */
    int localIndex;		/* Index of array variable in procedure's
				 * array of local variables. */
    Tcl_Obj *elemPtr;		/* Points to an object holding the name of
				 * an element to increment in the array. */
    long incrAmount;		/* Amount to be added to variable. */
{
    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 = TclGetElementOfIndexedArray(interp, localIndex, elemPtr,
	    TCL_LEAVE_ERR_MSG);
    if (varValuePtr == NULL) {
	Tcl_AddObjErrorInfo(interp,
		"\n    (reading value of variable to increment)", -1);
	return NULL;
    }

    /*
     * Reach into the object's representation to extract and 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)) {
	createdNewObj = 1;
	varValuePtr = Tcl_DuplicateObj(varValuePtr);
    }
#ifdef TCL_WIDE_INT_IS_LONG
    if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) {
	if (createdNewObj) {
	    Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
	}
	return NULL;
    }
    Tcl_SetLongObj(varValuePtr, (i + incrAmount));
#else
    if (varValuePtr->typePtr == &tclWideIntType) {
	Tcl_WideInt wide = varValuePtr->internalRep.wideValue;
	Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
    } else if (varValuePtr->typePtr == &tclIntType) {
	i = varValuePtr->internalRep.longValue;
	Tcl_SetIntObj(varValuePtr, i + incrAmount);
    } else {
	/*
	 * Not an integer or wide internal-rep...
	 */
	Tcl_WideInt wide;
	if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
	    if (createdNewObj) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
	    }
	    return NULL;
	}
	if (wide <= Tcl_LongAsWide(LONG_MAX)
		&& wide >= Tcl_LongAsWide(LONG_MIN)) {
	    Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
	} else {
	    Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
	}
    }
#endif

    /*
     * Store the variable's new value and run any write traces.
     */
    
    return TclSetElementOfIndexedArray(interp, localIndex, elemPtr,
	    varValuePtr, TCL_LEAVE_ERR_MSG);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar --
 *







<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







1855
1856
1857
1858
1859
1860
1861


1862














































































































































































































1863
1864
1865
1866
1867
1868
1869
1870
    }
#endif

    /*
     * Store the variable's new value and run any write traces.
     */
    


    return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,














































































































































































































	    varValuePtr, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar --
 *
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    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);







|







1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp.  May be
				 * either a scalar name or an array name
				 * or an element in an array. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
				 * TCL_LEAVE_ERR_MSG. */
{
    return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
2230
2231
2232
2233
2234
2235
2236
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
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    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. */
{
    Var dummyVar;
    Var *varPtr, *dummyVarPtr;
    Interp *iPtr = (Interp *) interp;
    Var *arrayPtr;
    ActiveVarTrace *activePtr;
    Tcl_Obj *objPtr;
    int result;



    varPtr = TclLookupVar(interp, part1, 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);
    }

    /*







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>

>
|




>







1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    int result;
    Tcl_Obj *part1Ptr;

    part1Ptr = Tcl_NewStringObj(part1, -1);
    Tcl_IncrRefCount(part1Ptr);
    result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
    TclDecrRefCount(part1Ptr);

    return result;
}


/*
 *----------------------------------------------------------------------
 *
 * TclObjUnsetVar2 --
 *
 *	Delete a variable, given a 2-object name.
 *
 * Results:
 *	Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
 *	if the variable can't be unset.  In the event of an error,
 *	if the TCL_LEAVE_ERR_MSG flag is set then an error message
 *	is left in the interp's result.
 *
 * Side effects:
 *	If part1ptr and part2Ptr indicate a local or global variable in interp,
 *	it is deleted.  If part1Ptr is an array name and part2Ptr is NULL, then
 *	the whole array is deleted.
 *
 *----------------------------------------------------------------------
 */

int
TclObjUnsetVar2(interp, part1Ptr, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    Tcl_Obj *part1Ptr;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    Var dummyVar;
    Var *varPtr, *dummyVarPtr;
    Interp *iPtr = (Interp *) interp;
    Var *arrayPtr;
    ActiveVarTrace *activePtr;
    Tcl_Obj *objPtr;
    int result;
    char *part1;

    part1 = TclGetString(part1Ptr);
    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
	    /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }
 
    result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);

    if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
	DeleteSearches(arrayPtr);
    }

    /*
2279
2280
2281
2282
2283
2284
2285
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
    varPtr->tracePtr = NULL;
    varPtr->searchPtr = NULL;

    /*
     * Call trace procedures for the variable being deleted. Then delete
     * its traces. Be sure to abort any other traces for the variable
     * that are still pending. Special tricks:
     * 1. We need to increment varPtr's refCount around this: CallTraces
     *    will use dummyVar so it won't increment varPtr's refCount itself.
     * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
     *    call unset traces even if other traces are pending.
     */

    if ((dummyVar.tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	varPtr->refCount++;
	dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	CallTraces(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->activeTracePtr;  activePtr != NULL;
	     activePtr = activePtr->nextPtr) {
	    if (activePtr->varPtr == varPtr) {
		activePtr->nextTracePtr = NULL;
	    }
	}
	varPtr->refCount--;
    }







|









|







|







2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
    varPtr->tracePtr = NULL;
    varPtr->searchPtr = NULL;

    /*
     * Call trace procedures for the variable being deleted. Then delete
     * its traces. Be sure to abort any other traces for the variable
     * that are still pending. Special tricks:
     * 1. We need to increment varPtr's refCount around this: CallVarTraces
     *    will use dummyVar so it won't increment varPtr's refCount itself.
     * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
     *    call unset traces even if other traces are pending.
     */

    if ((dummyVar.tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	varPtr->refCount++;
	dummyVar.flags &= ~VAR_TRACE_ACTIVE;
	CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
		| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
	while (dummyVar.tracePtr != NULL) {
	    VarTrace *tracePtr = dummyVar.tracePtr;
	    dummyVar.tracePtr = tracePtr->nextPtr;
	    Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	}
	for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
	     activePtr = activePtr->nextPtr) {
	    if (activePtr->varPtr == varPtr) {
		activePtr->nextTracePtr = NULL;
	    }
	}
	varPtr->refCount--;
    }
2329
2330
2331
2332
2333
2334
2335
2336

2337
2338
2339
2340
2341
2342
2343
	 *
	 * Bumping the count can lead to the odd situation that elements of the
	 * array are being deleted when the array still exists, but since the
	 * array is about to be removed anyway, that shouldn't really matter.
	 */
	varPtr->refCount++;
	DeleteArray(iPtr, part1, dummyVarPtr,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);

	/* Decr ref count */
	varPtr->refCount--;
    }
    if (TclIsVarScalar(dummyVarPtr)
	    && (dummyVarPtr->value.objPtr != NULL)) {
	objPtr = dummyVarPtr->value.objPtr;
	TclDecrRefCount(objPtr);







|
>







2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
	 *
	 * Bumping the count can lead to the odd situation that elements of the
	 * array are being deleted when the array still exists, but since the
	 * array is about to be removed anyway, that shouldn't really matter.
	 */
	varPtr->refCount++;
	DeleteArray(iPtr, part1, dummyVarPtr,
		(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) 
		| TCL_TRACE_UNSETS);
	/* Decr ref count */
	varPtr->refCount--;
    }
    if (TclIsVarScalar(dummyVarPtr)
	    && (dummyVarPtr->value.objPtr != NULL)) {
	objPtr = dummyVarPtr->value.objPtr;
	TclDecrRefCount(objPtr);
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    char *varName;		/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */







|







2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    CONST char *varName;	/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    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. */







|







2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    CONST char *part1;		/* Name of scalar variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
				 * and TCL_NAMESPACE_ONLY. */
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *varName;		/* Name of variable; may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits describing
				 * current trace, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */







|







2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of variable; may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits describing
				 * current trace, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    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,







|







2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits describing
				 * current trace, including any of
				 * TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
	    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 CallTraces.
     */

    for (activePtr = iPtr->activeTracePtr;  activePtr != NULL;
	 activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    activePtr->nextTracePtr = tracePtr->nextPtr;
	}
    }
    if (prevPtr == NULL) {
	varPtr->tracePtr = tracePtr->nextPtr;







|


|







2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
	    break;
	}
    }

    /*
     * The code below makes it possible to delete traces while traces
     * are active: it makes sure that the deleted trace won't be
     * processed by CallVarTraces.
     */

    for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
	 activePtr = activePtr->nextPtr) {
	if (activePtr->nextTracePtr == tracePtr) {
	    activePtr->nextTracePtr = tracePtr->nextPtr;
	}
    }
    if (prevPtr == NULL) {
	varPtr->tracePtr = tracePtr->nextPtr;
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *varName;		/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
				 * by this procedure, so this call will
				 * return the next trace after that one.







|







2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *varName;	/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed combo or TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
				 * by this procedure, so this call will
				 * return the next trace after that one.
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned







|







2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST char *part1;		/* Name of variable or array. */
    CONST char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure assocated with trace. */
    ClientData prevClientData;	/* If non-NULL, gives last value returned
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
 	}
 	if (strcmp("--", name) == 0) {
 	    i++;
 	}
    }

    for (; i < objc;  i++) {
	name = TclGetString(objv[i]);
	if ((Tcl_UnsetVar2(interp, name, (char *) NULL, flags) != TCL_OK)
		&& (flags == TCL_LEAVE_ERR_MSG)) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}








<
|







2535
2536
2537
2538
2539
2540
2541

2542
2543
2544
2545
2546
2547
2548
2549
 	}
 	if (strcmp("--", name) == 0) {
 	    i++;
 	}
    }

    for (; i < objc;  i++) {

	if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK)
		&& (flags == TCL_LEAVE_ERR_MSG)) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

2834
2835
2836
2837
2838
2839
2840



2841
2842
2843
2844
2845
2846
2847
2848
2849

2850
2851
2852
2853
2854
2855






2856






2857

2858
2859
2860
2861
2862
2863
2864
2865
int
Tcl_AppendObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{



    register Tcl_Obj *varValuePtr = NULL;
    					/* Initialized to avoid compiler
				         * warning. */
    int i;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
	if (varValuePtr == NULL) {
	    return TCL_ERROR;
	}
    } else {






	for (i = 2;  i < objc;  i++) {






	    varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,

		    objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}
    }
    Tcl_SetObjResult(interp, varValuePtr);
    return TCL_OK;







>
>
>









>






>
>
>
>
>
>
|
>
>
>
>
>
>
|
>
|







2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
int
Tcl_AppendObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Var *varPtr, *arrayPtr;
    char *part1;

    register Tcl_Obj *varValuePtr = NULL;
    					/* Initialized to avoid compiler
				         * warning. */
    int i;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
	if (varValuePtr == NULL) {
	    return TCL_ERROR;
	}
    } else {
	varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	part1 = TclGetString(objv[1]);
	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	for (i = 2;  i < objc;  i++) {	  
	    /*
	     * Note that we do not need to increase the refCount of
	     * the Var pointers: should a trace delete the variable,
	     * the return value of TclPtrSetVar will be NULL, and we 
	     * will not access the variable again.
	     */

	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, 
	            objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}
    }
    Tcl_SetObjResult(interp, varValuePtr);
    return TCL_OK;
2890
2891
2892
2893
2894
2895
2896


2897
2898
2899
2900
2901
2902
2903
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *varValuePtr, *newValuePtr;
    register List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    int numElems, numRequired, createdNewObj, createVar, i, j;



    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }
    if (objc == 2) {
	newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);







>
>







2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Tcl_Obj *varValuePtr, *newValuePtr;
    register List *listRepPtr;
    register Tcl_Obj **elemPtrs;
    int numElems, numRequired, createdNewObj, createVar, i, j;
    Var *varPtr, *arrayPtr;
    char *part1;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
	return TCL_ERROR;
    }
    if (objc == 2) {
	newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
2924
2925
2926
2927
2928
2929
2930

2931
2932
2933
2934



2935

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
	 * 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.



	 */

	varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_TRACE_READS);
















	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.
	     */
	    
	    char *p, *varName;
	    int nameBytes, i;

	    varName = Tcl_GetStringFromObj(objv[1], &nameBytes);
	    for (i = 0, p = varName;  i < nameBytes;  i++, p++) {
		if (*p == '(') {
		    p = (varName + nameBytes-1);	
		    if (*p == ')') { /* last char is ')' => array ref */
			/*
			 * This case occurs when we tried something like:
			 set x ""
			 lappend x(0) 44
			 */
			createVar = 0;
		    }
		    break;
		}
	    }
	    varValuePtr = Tcl_NewObj();
	    createdNewObj = 1;
	} else if (Tcl_IsShared(varValuePtr)) {	
	    varValuePtr = Tcl_DuplicateObj(varValuePtr);
	    createdNewObj = 1;
	}








>




>
>
>

>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<







2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717













2718




2719
2720
2721
2722
2723
2724
2725
	 * the variable will now each only be called once. Also, if the
	 * variable's old value is unshared we modify it directly, otherwise
	 * we create a new copy to modify: this is "copy on write".
	 */

	createdNewObj = 0;
	createVar = 1;

	/*
	 * Use the TCL_TRACE_READS flag to ensure that if we have an
	 * array with no elements set yet, but with a read trace on it,
	 * we will create the variable and get read traces triggered.
	 * Note that you have to protect the variable pointers around
	 * the TclPtrGetVar call to insure that they remain valid 
	 * even if the variable was undefined and unused.
	 */

	varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
		"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
	if (varPtr == NULL) {
	    return TCL_ERROR;
	}
	varPtr->refCount++;
	if (arrayPtr != NULL) {
	    arrayPtr->refCount++;
	}
	part1 = TclGetString(objv[1]);
	varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, 
	        (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG));
	varPtr->refCount--;
	if (arrayPtr != NULL) {
	    arrayPtr->refCount--;
	}

	if (varValuePtr == NULL) {
	    /*
	     * We couldn't read the old value: either the var doesn't yet
	     * exist or it's an array element.  If it's new, we will try to
	     * create it with Tcl_ObjSetVar2 below.
	     */
	    













	    createVar = (TclIsVarUndefined(varPtr));




	    varValuePtr = Tcl_NewObj();
	    createdNewObj = 1;
	} else if (Tcl_IsShared(varValuePtr)) {	
	    varValuePtr = Tcl_DuplicateObj(varValuePtr);
	    createdNewObj = 1;
	}

3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036

	/*
	 * 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 = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
		TCL_LEAVE_ERR_MSG);
	if (newValuePtr == NULL) {
	    if (createdNewObj && !createVar) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
	    }
	    return TCL_ERROR;
	}
    }







|
|







2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793

	/*
	 * Now store the list object back into the variable. If there is an
	 * error setting the new value, decrement its ref count if it
	 * was new and we didn't create the variable.
	 */
	
	newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, 
	            varValuePtr, TCL_LEAVE_ERR_MSG);	
	if (newValuePtr == NULL) {
	    if (createdNewObj && !createVar) {
		Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
	    }
	    return TCL_ERROR;
	}
    }
3081
3082
3083
3084
3085
3086
3087
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
	"anymore", "donesearch", "exists", "get", "names", "nextelement",
	"set", "size", "startsearch", "statistics", "unset", (char *) NULL
    };

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *resultPtr;
    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
     */
    

    varName = TclGetString(objv[2]);
    varPtr = TclLookupVar(interp, varName, (char *) 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 == CallTraces(iPtr, arrayPtr, varPtr, varName, NULL,
		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
	    return TCL_ERROR;
	}
    }

    /*
     * Verify that it is indeed an array variable. This test comes after
     * the traces - the variable may actually become an array as an effect 
     * of said traces.
     */

    notArray = 0;
    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
	    || TclIsVarUndefined(varPtr)) {
	notArray = 1;
    }

    /*
     * We have to wait to get the resultPtr until here because
     * CallTraces can affect the result.
     */

    resultPtr = Tcl_GetObjResult(interp);

    switch (index) {
        case ARRAY_ANYMORE: {
	    ArraySearch *searchPtr;







|



















>
|
|









|




















|







2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
	"anymore", "donesearch", "exists", "get", "names", "nextelement",
	"set", "size", "startsearch", "statistics", "unset", (char *) NULL
    };

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *resultPtr, *varNamePtr;
    int notArray;
    char *varName;
    int index, result;


    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
	return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
	    0, &index) != TCL_OK) {
    	return TCL_ERROR;
    }

    /*
     * Locate the array variable
     */
    
    varNamePtr = objv[2];
    varName = TclGetString(varNamePtr);
    varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
            /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    /*
     * Special array trace used to keep the env array in sync for
     * array names, array get, etc.
     */

    if (varPtr != NULL && varPtr->tracePtr != NULL
	    && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
	if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL,
		(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
		TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
	    return TCL_ERROR;
	}
    }

    /*
     * Verify that it is indeed an array variable. This test comes after
     * the traces - the variable may actually become an array as an effect 
     * of said traces.
     */

    notArray = 0;
    if ((varPtr == NULL) || !TclIsVarArray(varPtr)
	    || TclIsVarUndefined(varPtr)) {
	notArray = 1;
    }

    /*
     * We have to wait to get the resultPtr until here because
     * CallVarTraces can affect the result.
     */

    resultPtr = Tcl_GetObjResult(interp);

    switch (index) {
        case ARRAY_ANYMORE: {
	    ArraySearch *searchPtr;
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
	    if (notArray) {
		return TCL_OK;
	    }
	    if (objc == 3) {
		/*
		 * When no pattern is given, just unset the whole array
		 */
		if (Tcl_UnsetVar2(interp, varName, (char *) NULL, 0)
			!= TCL_OK) {
		    return TCL_ERROR;
		}
	    } else {
		pattern = Tcl_GetString(objv[3]);
		for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
			&search);
		     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
		    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		    if (TclIsVarUndefined(varPtr2)) {
			continue;
		    }
		    name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
		    if (Tcl_StringMatch(name, pattern) &&
			    (Tcl_UnsetVar2(interp, varName, name, 0)
				    != TCL_OK)) {
			return TCL_ERROR;
		    }
		}
	    }
	    break;
	}







|














|







3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
	    if (notArray) {
		return TCL_OK;
	    }
	    if (objc == 3) {
		/*
		 * When no pattern is given, just unset the whole array
		 */
		if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0)
			!= TCL_OK) {
		    return TCL_ERROR;
		}
	    } else {
		pattern = Tcl_GetString(objv[3]);
		for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
			&search);
		     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
		    varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
		    if (TclIsVarUndefined(varPtr2)) {
			continue;
		    }
		    name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
		    if (Tcl_StringMatch(name, pattern) &&
			    (TclObjUnsetVar2(interp, varNamePtr, name, 0)
				    != TCL_OK)) {
			return TCL_ERROR;
		    }
		}
	    }
	    break;
	}
3579
3580
3581
3582
3583
3584
3585
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
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Obj *arrayNameObj;	/* The array name. */
    Tcl_Obj *arrayElemObj;	/* The array elements list.  If this is
				 * NULL, create an empty array. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj **elemPtrs;
    int result, elemLen, i;
    char *varName, *p;
    
    varName = TclGetString(arrayNameObj);
    for (p = varName; *p ; p++) {
	if (*p == '(') {
	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p == ')') {
		VarErrMsg(interp, varName, NULL, "set", needArray);
		return TCL_ERROR;
	    }
	    break;
	}
    }

    varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,

            /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);




    if (arrayElemObj != NULL) {
	result = Tcl_ListObjGetElements(interp, arrayElemObj,
		&elemLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    "list must have an even number of elements", -1);
	    return TCL_ERROR;
	}
	if (elemLen > 0) {






	    for (i = 0;  i < elemLen;  i += 2) {
		if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i],




			elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
		    result = TCL_ERROR;
		    break;
		}
	    }
	    return result;
	}
    }







|


|
|
|
<
<
|
<
|



<



|
>
|
>
>
>














>
>
>
>
>
>

|
>
>
>
>
|







3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349


3350

3351
3352
3353
3354

3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Obj *arrayNameObj;	/* The array name. */
    Tcl_Obj *arrayElemObj;	/* The array elements list.  If this is
				 * NULL, create an empty array. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj **elemPtrs;
    int result, elemLen, i, nameLen;
    char *varName, *p;
    
    varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
    p = varName + nameLen - 1;
    if (*p == ')') {


	while (--p >= varName) {

	    if (*p == '(') {
		VarErrMsg(interp, varName, NULL, "set", needArray);
		return TCL_ERROR;
	    }

	}
    }

    varPtr = TclObjLookupVar(interp, arrayNameObj, NULL,
	    /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
	    /*createPart2*/ 0, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }

    if (arrayElemObj != NULL) {
	result = Tcl_ListObjGetElements(interp, arrayElemObj,
		&elemLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    "list must have an even number of elements", -1);
	    return TCL_ERROR;
	}
	if (elemLen > 0) {
	    /*
	     * We needn't worry about traces invalidating arrayPtr:
	     * should that be the case, TclPtrSetVar will return NULL
	     * so that we break out of the loop and return an error.
	     */

	    for (i = 0;  i < elemLen;  i += 2) {
		char *part2 = TclGetString(elemPtrs[i]);
		Var *elemVarPtr = TclLookupArrayElement(interp, varName, 
                        part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
		if ((elemVarPtr == NULL) ||
		        (TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
			 part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
		    result = TCL_ERROR;
		    break;
		}
	    }
	    return result;
	}
    }
3645
3646
3647
3648
3649
3650
3651
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
	    /*
	     * Either an array element, or a scalar: lose!
	     */
	    
	    VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Create variable for new array.
	 */
	
	varPtr = TclLookupVar(interp, varName, (char *) NULL,
		TCL_LEAVE_ERR_MSG, "set",
	        /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);

	/*
	 * Still couldn't do it - this can occur if a non-existent
	 * namespace was specified
	 */
	if (varPtr == NULL) {
	    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;
}

/*
 *----------------------------------------------------------------------
 *
 * MakeUpvar --
 *
 *	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
MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
    Interp *iPtr;		/* Interpreter containing variables. Used
				 * for error messages, too. */
    CallFrame *framePtr;	/* Call frame containing "other" variable.
				 * NULL means use global :: context. */
    char *otherP1;
    CONST char *otherP2;	/* Two-part name of variable in framePtr. */
    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. */


{
    Tcl_HashEntry *hPtr;
    Var *otherPtr, *varPtr, *arrayPtr;
    CallFrame *varFramePtr;
    CallFrame *savedFramePtr = NULL;  /* Init. to avoid compiler warning. */
    Tcl_HashTable *tablePtr;
    Namespace *nsPtr, *altNsPtr, *dummyNsPtr;
    CONST char *tail;
    int new;

    /*
     * 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 TclLookupVar.
     */


    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	savedFramePtr = iPtr->varFramePtr;
	iPtr->varFramePtr = framePtr;
    }
    otherPtr = TclLookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
	    (otherFlags | TCL_LEAVE_ERR_MSG), "access",
            /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	iPtr->varFramePtr = savedFramePtr;
    }
    if (otherPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Now create a hashtable entry for "myName". Create it as either a
     * namespace variable or as a local variable in a procedure call
     * frame. Interpret myName 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).
     * If creating myName in the active procedure, look first in the
     * frame's array of compiler-allocated local variables, then in its
     * hashtable for runtime-created local variables. Create that
     * procedure's local variable hashtable if necessary.
     */

    varFramePtr = iPtr->varFramePtr;
    if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
	    || (varFramePtr == NULL)
	    || !varFramePtr->isProcCallFrame
	    || (strstr(myName, "::") != NULL)) {
	TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName,
		(Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail);

        if (nsPtr == NULL) {
            nsPtr = altNsPtr;
        }
        if (nsPtr == NULL) {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
		    myName, "\": unknown namespace", (char *) NULL);
            return TCL_ERROR;
        }
	
	/*
	 * 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) {




	    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;
        }
	
	hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new);
	if (new) {
	    varPtr = NewVar();
	    Tcl_SetHashValue(hPtr, varPtr);
	    varPtr->hPtr = hPtr;
            varPtr->nsPtr = nsPtr;
	} else {
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	}
    } else {			/* look in the call frame */
	Proc *procPtr = varFramePtr->procPtr;
	int localCt = procPtr->numCompiledLocals;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	Var *localVarPtr = varFramePtr->compiledLocals;
	int nameLen = strlen(myName);
	int i;

	varPtr = NULL;
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		char *localName = localVarPtr->name;
		if ((myName[0] == localName[0])
		        && (nameLen == localPtr->nameLength)
		        && (strcmp(myName, localName) == 0)) {
		    varPtr = localVarPtr;
		    new = 0;
		    break;
		}
	    }
	    localVarPtr++;
	    localPtr = localPtr->nextPtr;
	}

	if (varPtr == NULL) {	/* look in frame's local var hashtable */
	    tablePtr = varFramePtr->varTablePtr;
	    if (tablePtr == NULL) {
		tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
		Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
		varFramePtr->varTablePtr = tablePtr;
	    }
	    hPtr = Tcl_CreateHashEntry(tablePtr, myName, &new);
	    if (new) {
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
                varPtr->nsPtr = varFramePtr->nsPtr;
	    } else {
		varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }
	}




    }

    if (!new) {




	/*
	 * The variable already exists. 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 (varPtr == otherPtr) {
	    Tcl_SetResult((Tcl_Interp *) iPtr,
		    "can't upvar from variable to itself", TCL_STATIC);
	    return TCL_ERROR;
	}
	if (TclIsVarLink(varPtr)) {
	    Var *linkPtr = varPtr->value.linkPtr;
	    if (linkPtr == otherPtr) {
		return TCL_OK;
	    }
	    linkPtr->refCount--;
	    if (TclIsVarUndefined(linkPtr)) {
		CleanupVar(linkPtr, (Var *) NULL);
	    }
	} else if (!TclIsVarUndefined(varPtr)) {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
		    "\" already exists", (char *) NULL);
	    return TCL_ERROR;
	} else if (varPtr->tracePtr != NULL) {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
		    "\" has traces: can't use for upvar", (char *) NULL);
	    return TCL_ERROR;
	}
    }
    TclSetVarLink(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.linkPtr = otherPtr;
    otherPtr->refCount++;
    return TCL_OK;







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












|

















|
|
|


|

|



|

>
>

|


<
<
<
|
<




|


>

<


|



|





<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
|
<
<
<
|
<
<
|
|
<
<
<
<
|






|
|
>
>
>
>

|
|
|
|

<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
|
<
>
|
<
|
<
|
<
|
<
<
<
<
<
<
<
<
|
|
>
>
>
>


|
>
>
>
>

|





<
<
<
<
<









|



<
<
<
<







3413
3414
3415
3416
3417
3418
3419
















3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468



3469

3470
3471
3472
3473
3474
3475
3476
3477
3478

3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490














3491



3492



3493


3494
3495




3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514









3515
3516





3517










3518


3519

3520
3521

3522

3523

3524








3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544





3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557




3558
3559
3560
3561
3562
3563
3564
	    /*
	     * Either an array element, or a scalar: lose!
	     */
	    
	    VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
	    return TCL_ERROR;
	}
















    }
    TclSetVarArray(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.tablePtr =
	(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ObjMakeUpvar --
 *
 *	This procedure does all of the work of the "global" and "upvar"
 *	commands.
 *
 * Results:
 *	A standard Tcl completion code. If an error occurs then an
 *	error message is left in iPtr->result.
 *
 * Side effects:
 *	The variable given by myName is linked to the variable in framePtr
 *	given by otherP1 and otherP2, so that references to myName are
 *	redirected to the other variable like a symbolic link.
 *
 *----------------------------------------------------------------------
 */

static int
ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index)
    Tcl_Interp *interp;		/* Interpreter containing variables. Used
			         * for error messages, too. */
    CallFrame *framePtr;	/* Call frame containing "other" variable.
				 * NULL means use global :: context. */
    Tcl_Obj *otherP1Ptr;
    CONST char *otherP2;	/* Two-part name of variable in framePtr. */
    CONST int otherFlags;	/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of "other" variable. */
    CONST char *myName;		/* Name of variable which will refer to
				 * otherP1/otherP2. Must be a scalar. */
    CONST int myFlags;		/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of myName. */
    int index;                  /* If the variable to be linked is an indexed
				 * scalar, this is its index. Otherwise, -1. */
{
    Interp *iPtr = (Interp *) interp;
    Var *otherPtr, *varPtr, *arrayPtr;
    CallFrame *varFramePtr;



    CONST char *errMsg;


    /*
     * Find "other" in "framePtr". If not looking up other in just the
     * current namespace, temporarily replace the current var frame
     * pointer in the interpreter in order to use TclObjLookupVar.
     */

    varFramePtr = iPtr->varFramePtr;
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {

	iPtr->varFramePtr = framePtr;
    }
    otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
	    (otherFlags | TCL_LEAVE_ERR_MSG), "access",
            /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
	iPtr->varFramePtr = varFramePtr;
    }
    if (otherPtr == NULL) {
	return TCL_ERROR;
    }















    if (index >= 0) {



	if (!varFramePtr->isProcCallFrame) {



	    panic("ObjMakeUpVar called with an index outside from a proc.\n");


	}
	varPtr = &(varFramePtr->compiledLocals[index]);




    } else {
	/*
	 * Check that we are not trying to create a namespace var linked to
	 * a local variable in a procedure. If we allowed this, the local
	 * variable in the shorter-lived procedure frame could go away
	 * leaving the namespace var's reference invalid.
	 */
	
	if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) 
	    && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
		|| (varFramePtr == NULL)
		|| !varFramePtr->isProcCallFrame
		|| (strstr(myName, "::") != NULL))) {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
		    myName, "\": upvar won't create namespace variable that ",
		    "refers to procedure variable", (char *) NULL);
	    return TCL_ERROR;
	}
	









	/*
	 * Lookup and eventually create the new variable.





	 */










	


	varPtr = TclLookupSimpleVar(interp, myName, myFlags, /*create*/ 1, 

				    &errMsg, &index);
	if (varPtr == NULL) {

	    VarErrMsg(interp, myName, NULL, "create", errMsg);

	    return TCL_ERROR;

	}








    }

    if (varPtr == otherPtr) {
	Tcl_SetResult((Tcl_Interp *) iPtr,
		      "can't upvar from variable to itself", TCL_STATIC);
	return TCL_ERROR;
    }

    if (varPtr->tracePtr != NULL) {
	Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
	        "\" has traces: can't use for upvar", (char *) NULL);
	return TCL_ERROR;
    } else if (!TclIsVarUndefined(varPtr)) {
	/*
	 * The variable already existed. Make sure this variable "varPtr"
	 * isn't the same as "otherPtr" (avoid circular links). Also, if
	 * it's not an upvar then it's an error. If it is an upvar, then
	 * just disconnect it from the thing it currently refers to.
	 */






	if (TclIsVarLink(varPtr)) {
	    Var *linkPtr = varPtr->value.linkPtr;
	    if (linkPtr == otherPtr) {
		return TCL_OK;
	    }
	    linkPtr->refCount--;
	    if (TclIsVarUndefined(linkPtr)) {
		CleanupVar(linkPtr, (Var *) NULL);
	    }
	} else {
	    Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
		    "\" already exists", (char *) NULL);
	    return TCL_ERROR;




	}
    }
    TclSetVarLink(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.linkPtr = otherPtr;
    otherPtr->refCount++;
    return TCL_OK;
3897
3898
3899
3900
3901
3902
3903
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

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". */
    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. */
{
    int result;
    CallFrame *framePtr;
    register char *p;

    result = TclGetFrame(interp, frameName, &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }

    /*
     * Figure out whether varName is an array reference, then call
     * MakeUpvar to do all the real work.
     */

    for (p = varName;  *p != '\0';  p++) {
	if (*p == '(') {
	    char *openParen = p;
	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p != ')') {
		goto scalar;
	    }
	    *openParen = '\0';
	    *p = '\0';
	    result = MakeUpvar((Interp *) interp, framePtr, varName,
		    openParen+1, 0, localName, flags);
	    *openParen = '(';
	    *p = ')';
	    return result;
	}
    }

    scalar:
    return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL,
	    0, localName, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpVar2 --
 *







|






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|







3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600




































3601
3602
3603
3604
3605
3606
3607
3608

int
Tcl_UpVar(interp, frameName, varName, localName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *frameName;	/* Name of the frame containing the source
				 * variable, such as "1" or "#0". */
    CONST char *varName;	/* Name of a variable in interp to link to.
				 * May be either a scalar name or an
				 * element in an array. */
    CONST char *localName;	/* Name of link variable. */
    int flags;			/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of localName. */
{




































    return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UpVar2 --
 *
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985




3986
3987
3988
3989
3990
3991
3992



3993
3994
3995
3996
3997
3998
3999

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". */
    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;





    result = TclGetFrame(interp, frameName, &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    return MakeUpvar((Interp *) interp, framePtr, part1, part2, 0,
	    localName, flags);



}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVariableFullName --
 *







|








>
>
>
>





|
|
>
>
>







3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660

int
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
    Tcl_Interp *interp;		/* Interpreter containing variables.  Used
				 * for error messages too. */
    CONST char *frameName;	/* Name of the frame containing the source
				 * variable, such as "1" or "#0". */
    CONST char *part1;
    CONST char *part2;		/* Two parts of source variable name to
				 * link to. */
    CONST char *localName;	/* Name of link variable. */
    int flags;			/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of localName. */
{
    int result;
    CallFrame *framePtr;
    Tcl_Obj *part1Ptr;

    part1Ptr = Tcl_NewStringObj(part1, -1);
    Tcl_IncrRefCount(part1Ptr);

    result = TclGetFrame(interp, frameName, &framePtr);
    if (result == -1) {
	return TCL_ERROR;
    }
    result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
	    localName, flags, -1);

    TclDecrRefCount(part1Ptr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVariableFullName --
 *
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
            tail++;
	}

	/*
	 * Link to the variable "varName" in the global :: namespace.
	 */
	
	result = MakeUpvar(iPtr, (CallFrame *) NULL,
		varName, (char *) NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
	        /*myName*/ tail, /*myFlags*/ 0);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}








|
|
|







3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
            tail++;
	}

	/*
	 * Link to the variable "varName" in the global :: namespace.
	 */
	
	result = ObjMakeUpvar(interp, (CallFrame *) NULL,
		objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
	        /*myName*/ tail, /*myFlags*/ 0, -1);
	if (result != TCL_OK) {
	    return result;
	}
    }
    return TCL_OK;
}

4171
4172
4173
4174
4175
4176
4177

4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189

4190
4191
4192
4193
4194
4195
4196
4197
4198
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    char *varName, *tail, *cp;
    Var *varPtr, *arrayPtr;
    Tcl_Obj *varValuePtr;
    int i, result;


    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
	return TCL_ERROR;
    }

    for (i = 1;  i < objc;  i = i+2) {
	/*
	 * Look up each variable in the current namespace context, creating
	 * it if necessary.
	 */
	

	varName = TclGetString(objv[i]);
	varPtr = TclLookupVar(interp, varName, (char *) 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.







>












>
|
|







3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    char *varName, *tail, *cp;
    Var *varPtr, *arrayPtr;
    Tcl_Obj *varValuePtr;
    int i, result;
    Tcl_Obj *varNamePtr;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
	return TCL_ERROR;
    }

    for (i = 1;  i < objc;  i = i+2) {
	/*
	 * Look up each variable in the current namespace context, creating
	 * it if necessary.
	 */
	
	varNamePtr = objv[i];
	varName = TclGetString(varNamePtr);
	varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
                (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
                /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
	
        if (arrayPtr != NULL) {
            /*
             * Variable cannot be an element in an array.  If arrayPtr is
             * non-null, it is, so throw up an error and return.
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
	 * 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 = Tcl_ObjSetVar2(interp, objv[i], 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







|
|







3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
	 * Otherwise, if the variable is new, leave it undefined.
	 * (If the variable already exists and no value was specified,
	 * leave its value unchanged; just create the local link if
	 * we're in a Tcl procedure).
	 */

	if (i+1 < objc) {	/* a value was specified */
	    varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
		    objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
	    if (varValuePtr == NULL) {
		return TCL_ERROR;
	    }
	}

	/*
	 * If we are executing inside a Tcl procedure, create a local
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
	    }
	    
	    /*
	     * Create a local link "tail" to the variable "varName" in the
	     * current namespace.
	     */
	    
	    result = MakeUpvar(iPtr, (CallFrame *) NULL,
		    /*otherP1*/ varName, /*otherP2*/ (char *) NULL,
                    /*otherFlags*/ TCL_NAMESPACE_ONLY,
		    /*myName*/ tail, /*myFlags*/ 0);
	    if (result != TCL_OK) {
		return result;
	    }
	}
    }
    return TCL_OK;
}







|
|

|







3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
	    }
	    
	    /*
	     * Create a local link "tail" to the variable "varName" in the
	     * current namespace.
	     */
	    
	    result = ObjMakeUpvar(interp, (CallFrame *) NULL,
		    /*otherP1*/ varNamePtr, /*otherP2*/ NULL,
                    /*otherFlags*/ TCL_NAMESPACE_ONLY,
		    /*myName*/ tail, /*myFlags*/ 0, -1);
	    if (result != TCL_OK) {
		return result;
	    }
	}
    }
    return TCL_OK;
}
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
int
Tcl_UpvarObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    register Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr;
    char *frameSpec, *otherVarName, *myVarName;
    register char *p;
    int result;

    if (objc < 3) {
	upvarSyntax:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?level? otherVar localVar ?otherVar localVar ...?");
	return TCL_ERROR;







<

|
<







3956
3957
3958
3959
3960
3961
3962

3963
3964

3965
3966
3967
3968
3969
3970
3971
int
Tcl_UpvarObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{

    CallFrame *framePtr;
    char *frameSpec, *localName;

    int result;

    if (objc < 3) {
	upvarSyntax:
	Tcl_WrongNumArgs(interp, 1, objv,
		"?level? otherVar localVar ?otherVar localVar ...?");
	return TCL_ERROR;
4329
4330
4331
4332
4333
4334
4335
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
    /*
     * 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) {
	myVarName = TclGetString(objv[1]);
	otherVarName = TclGetString(objv[0]);
	for (p = otherVarName;  *p != 0;  p++) {
	    if (*p == '(') {
		char *openParen = p;

		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p != ')') {
		    goto scalar;
		}
		*openParen = '\0';
		*p = '\0';
		result = MakeUpvar(iPtr, framePtr,
		        otherVarName, openParen+1, /*otherFlags*/ 0,
			myVarName, /*flags*/ 0);
		*openParen = '(';
		*p = ')';
		goto checkResult;
	    }
	}
	scalar:
	result = MakeUpvar(iPtr, framePtr, otherVarName, (char *) NULL, 0,
	        myVarName, /*flags*/ 0);

	checkResult:
	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}








|
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<







3990
3991
3992
3993
3994
3995
3996
3997




3998




















3999

4000
4001
4002
4003
4004
4005
4006
    /*
     * Iterate over each (other variable, local variable) pair.
     * Divide the other variable name into two parts, then call
     * MakeUpvar to do all the work of linking it to the local variable.
     */

    for ( ;  objc > 0;  objc -= 2, objv += 2) {
	localName = TclGetString(objv[1]);




	result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],




















		NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);

	if (result != TCL_OK) {
	    return TCL_ERROR;
	}
    }
    return TCL_OK;
}

4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
	Tcl_DecrRefCount((Tcl_Obj *) result);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * CallTraces --
 *
 *	This procedure is invoked to find and invoke relevant
 *	trace procedures associated with a particular operation on
 *	a variable. This procedure invokes traces both on the
 *	variable and on its containing array (where relevant).
 *
 * Results:







|







4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
	Tcl_DecrRefCount((Tcl_Obj *) result);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * CallVarTraces --
 *
 *	This procedure is invoked to find and invoke relevant
 *	trace procedures associated with a particular operation on
 *	a variable. This procedure invokes traces both on the
 *	variable and on its containing array (where relevant).
 *
 * Results:
4421
4422
4423
4424
4425
4426
4427
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
 *	Almost anything can happen, depending on trace; this procedure
 *	itself doesn't have any side effects.
 *
 *----------------------------------------------------------------------
 */

int 
CallTraces(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. */
    char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    int flags;			/* Flags passed to trace procedures:
				 * indicates what's happening to variable,
				 * plus other stuff like TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, and
				 * TCL_INTERP_DESTROYED. */
    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, *openParen, *p;

    Tcl_DString nameCopy;
    int copiedName;
    int code = TCL_OK;
    int disposeFlags = 0;

    /*
     * If there are already similar trace procedures active for the







|






|






|





|
>







4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
 *	Almost anything can happen, depending on trace; this procedure
 *	itself doesn't have any side effects.
 *
 *----------------------------------------------------------------------
 */

int 
CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
    Interp *iPtr;		/* Interpreter containing variable. */
    register Var *arrayPtr;	/* Pointer to array variable that contains
				 * the variable, or NULL if the variable
				 * isn't an element of an array. */
    Var *varPtr;		/* Variable whose traces are to be
				 * invoked. */
    CONST char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    int flags;			/* Flags passed to trace procedures:
				 * indicates what's happening to variable,
				 * plus other stuff like TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY, and
				 * TCL_INTERP_DESTROYED. */
    CONST int leaveErrMsg;	/* If true, and one of the traces indicates an
				 * error, then leave an error message and stack
				 * trace information in *iPTr. */
{
    register VarTrace *tracePtr;
    ActiveVarTrace active;
    char *result;
    CONST char *openParen, *p;
    Tcl_DString nameCopy;
    int copiedName;
    int code = TCL_OK;
    int disposeFlags = 0;

    /*
     * If there are already similar trace procedures active for the
4481
4482
4483
4484
4485
4486
4487

4488
4489
4490
4491
4492


4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
		openParen = p;
		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p == ')') {
		    int offset = (openParen - part1);

		    Tcl_DStringInit(&nameCopy);
		    Tcl_DStringAppend(&nameCopy, part1, (p-part1));
		    part2 = Tcl_DStringValue(&nameCopy) + offset + 1;
		    part1 = Tcl_DStringValue(&nameCopy);
		    part1[offset] = 0;


		    copiedName = 1;
		}
		break;
	    }
	}
    }

    /*
     * Invoke traces on the array containing the variable, if relevant.
     */

    result = NULL;
    active.nextPtr = iPtr->activeTracePtr;
    iPtr->activeTracePtr = &active;
    Tcl_Preserve((ClientData) iPtr);
    if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
	active.varPtr = arrayPtr;
	for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
	     tracePtr = active.nextTracePtr) {
	    active.nextTracePtr = tracePtr->nextPtr;
	    if (!(tracePtr->flags & flags)) {







>


<
|
|
>
>












|
|







4118
4119
4120
4121
4122
4123
4124
4125
4126
4127

4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
		openParen = p;
		do {
		    p++;
		} while (*p != '\0');
		p--;
		if (*p == ')') {
		    int offset = (openParen - part1);
		    char *newPart1;
		    Tcl_DStringInit(&nameCopy);
		    Tcl_DStringAppend(&nameCopy, part1, (p-part1));

		    newPart1 = Tcl_DStringValue(&nameCopy);
		    newPart1[offset] = 0;
		    part1 = newPart1;
		    part2 = newPart1 + offset + 1;
		    copiedName = 1;
		}
		break;
	    }
	}
    }

    /*
     * Invoke traces on the array containing the variable, if relevant.
     */

    result = NULL;
    active.nextPtr = iPtr->activeVarTracePtr;
    iPtr->activeVarTracePtr = &active;
    Tcl_Preserve((ClientData) iPtr);
    if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
	active.varPtr = arrayPtr;
	for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
	     tracePtr = active.nextTracePtr) {
	    active.nextTracePtr = tracePtr->nextPtr;
	    if (!(tracePtr->flags & flags)) {
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
     * Restore the variable's flags, remove the record of our active
     * traces, and then return.
     */

    done:
    if (code == TCL_ERROR) {
	if (leaveErrMsg) {
	    char *type = "";
	    switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
		case TCL_TRACE_READS: {
		    type = "read";
		    break;
		}
		case TCL_TRACE_WRITES: {
		    type = "set";







|







4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
     * Restore the variable's flags, remove the record of our active
     * traces, and then return.
     */

    done:
    if (code == TCL_ERROR) {
	if (leaveErrMsg) {
	    CONST char *type = "";
	    switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
		case TCL_TRACE_READS: {
		    type = "read";
		    break;
		}
		case TCL_TRACE_WRITES: {
		    type = "set";
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
	arrayPtr->refCount--;
    }
    if (copiedName) {
	Tcl_DStringFree(&nameCopy);
    }
    varPtr->flags &= ~VAR_TRACE_ACTIVE;
    varPtr->refCount--;
    iPtr->activeTracePtr = active.nextPtr;
    Tcl_Release((ClientData) iPtr);
    return code;
}

/*
 *----------------------------------------------------------------------
 *







|







4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
	arrayPtr->refCount--;
    }
    if (copiedName) {
	Tcl_DStringFree(&nameCopy);
    }
    varPtr->flags &= ~VAR_TRACE_ACTIVE;
    varPtr->refCount--;
    iPtr->activeVarTracePtr = active.nextPtr;
    Tcl_Release((ClientData) iPtr);
    return code;
}

/*
 *----------------------------------------------------------------------
 *
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
 *
 *----------------------------------------------------------------------
 */

static ArraySearch *
ParseSearchId(interp, varPtr, varName, handleObj)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    Var *varPtr;		/* Array variable search is for. */
    char *varName;		/* Name of array variable that search is
				 * supposed to be for. */
    Tcl_Obj *handleObj;		/* Object containing id of search. Must have
				 * form "search-num-var" where "num" is a
				 * decimal number and "var" is a variable
				 * name. */
{
    register char *string;







|
|







4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
 *
 *----------------------------------------------------------------------
 */

static ArraySearch *
ParseSearchId(interp, varPtr, varName, handleObj)
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    CONST Var *varPtr;		/* Array variable search is for. */
    CONST char *varName;	/* Name of array variable that search is
				 * supposed to be for. */
    Tcl_Obj *handleObj;		/* Object containing id of search. Must have
				 * form "search-num-var" where "num" is a
				 * decimal number and "var" is a variable
				 * name. */
{
    register char *string;
4901
4902
4903
4904
4905
4906
4907
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
	}

	/*
	 * 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 CallTraces the variable's
	 * fully-qualified name so that any called trace procedures can
	 * refer to these variables being deleted.
	 */

	if (varPtr->tracePtr != NULL) {
	    objPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(objPtr); /* until done with traces */
	    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
	    CallTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
		    NULL, flags, /* leaveErrMsg */ 0);
	    Tcl_DecrRefCount(objPtr); /* free no longer needed obj */

	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	    







|








|








|







4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
	}

	/*
	 * Invoke traces on the variable that is being deleted, then
	 * free up the variable's space (no need to free the hash entry
	 * here, unless we're dealing with a global variable: the
	 * hash entries will be deleted automatically when the whole
	 * table is deleted). Note that we give CallVarTraces the variable's
	 * fully-qualified name so that any called trace procedures can
	 * refer to these variables being deleted.
	 */

	if (varPtr->tracePtr != NULL) {
	    objPtr = Tcl_NewObj();
	    Tcl_IncrRefCount(objPtr); /* until done with traces */
	    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
	    CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
		    NULL, flags, /* leaveErrMsg */ 0);
	    Tcl_DecrRefCount(objPtr); /* free no longer needed obj */

	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	    
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057

	/*
	 * Invoke traces on the variable that is being deleted. Then delete
	 * the variable's trace records.
	 */

	if (varPtr->tracePtr != NULL) {
	    CallTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL,
		    flags, /* leaveErrMsg */ 0);
	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}








|






|







4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696

	/*
	 * Invoke traces on the variable that is being deleted. Then delete
	 * the variable's trace records.
	 */

	if (varPtr->tracePtr != NULL) {
	    CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL,
		    flags, /* leaveErrMsg */ 0);
	    while (varPtr->tracePtr != NULL) {
		VarTrace *tracePtr = varPtr->tracePtr;
		varPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == varPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}

5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
 *
 *----------------------------------------------------------------------
 */

static void
DeleteArray(iPtr, arrayName, varPtr, flags)
    Interp *iPtr;			/* Interpreter containing array. */
    char *arrayName;			/* Name of array (used for trace
					 * callbacks). */
    Var *varPtr;			/* Pointer to variable structure. */
    int flags;				/* Flags to pass to CallTraces:
					 * TCL_TRACE_UNSETS and sometimes
					 * TCL_INTERP_DESTROYED,
					 * TCL_NAMESPACE_ONLY, or
					 * TCL_GLOBAL_ONLY. */
{
    Tcl_HashSearch search;
    register Tcl_HashEntry *hPtr;







|


|







4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
 *
 *----------------------------------------------------------------------
 */

static void
DeleteArray(iPtr, arrayName, varPtr, flags)
    Interp *iPtr;			/* Interpreter containing array. */
    CONST char *arrayName;	        /* Name of array (used for trace
					 * callbacks). */
    Var *varPtr;			/* Pointer to variable structure. */
    int flags;				/* Flags to pass to CallVarTraces:
					 * TCL_TRACE_UNSETS and sometimes
					 * TCL_INTERP_DESTROYED,
					 * TCL_NAMESPACE_ONLY, or
					 * TCL_GLOBAL_ONLY. */
{
    Tcl_HashSearch search;
    register Tcl_HashEntry *hPtr;
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
	    objPtr = elPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    elPtr->value.objPtr = NULL;
	}
	elPtr->hPtr = NULL;
	if (elPtr->tracePtr != NULL) {
	    elPtr->flags &= ~VAR_TRACE_ACTIVE;
	    CallTraces(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->activeTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == elPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	TclSetVarUndefined(elPtr);







|







|







4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
	    objPtr = elPtr->value.objPtr;
	    TclDecrRefCount(objPtr);
	    elPtr->value.objPtr = NULL;
	}
	elPtr->hPtr = NULL;
	if (elPtr->tracePtr != NULL) {
	    elPtr->flags &= ~VAR_TRACE_ACTIVE;
	    CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
		    Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
		    /* leaveErrMsg */ 0);
	    while (elPtr->tracePtr != NULL) {
		VarTrace *tracePtr = elPtr->tracePtr;
		elPtr->tracePtr = tracePtr->nextPtr;
		Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
	    }
	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
		 activePtr = activePtr->nextPtr) {
		if (activePtr->varPtr == elPtr) {
		    activePtr->nextTracePtr = NULL;
		}
	    }
	}
	TclSetVarUndefined(elPtr);
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
 *
 *----------------------------------------------------------------------
 */

static void
VarErrMsg(interp, part1, part2, operation, reason)
    Tcl_Interp *interp;         /* Interpreter in which to record message. */
    char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    char *operation;            /* String describing operation that failed,
                                 * e.g. "read", "set", or "unset". */
    char *reason;               /* String describing why operation failed. */
{
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
	    (char *) NULL);
    if (part2 != NULL) {
        Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
    }
    Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceVarExists --
 *
 *	This is called from info exists.  We need to trigger read







|

|

|









<







4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879

4880
4881
4882
4883
4884
4885
4886
 *
 *----------------------------------------------------------------------
 */

static void
VarErrMsg(interp, part1, part2, operation, reason)
    Tcl_Interp *interp;         /* Interpreter in which to record message. */
    CONST char *part1;
    CONST char *part2;		/* Variable's two-part name. */
    CONST char *operation;      /* String describing operation that failed,
                                 * e.g. "read", "set", or "unset". */
    CONST char *reason;         /* String describing why operation failed. */
{
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
	    (char *) NULL);
    if (part2 != NULL) {
        Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
    }
    Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}


/*
 *----------------------------------------------------------------------
 *
 * TclTraceVarExists --
 *
 *	This is called from info exists.  We need to trigger read
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
 *
 *----------------------------------------------------------------------
 */

Var *
TclVarTraceExists(interp, varName)
    Tcl_Interp *interp;		/* The interpreter */
    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,







|







4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
 *
 *----------------------------------------------------------------------
 */

Var *
TclVarTraceExists(interp, varName)
    Tcl_Interp *interp;		/* The interpreter */
    CONST char *varName;	/* The variable name */
{
    Var *varPtr;
    Var *arrayPtr;

    /*
     * The choice of "create" flag values is delicate here, and
     * matches the semantics of GetVar.  Things are still not perfect,
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303





































































































































































































    if (varPtr == NULL) {
	return NULL;
    }

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	CallTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
		TCL_TRACE_READS, /* leaveErrMsg */ 0);
    }

    /*
     * If the variable doesn't exist anymore and no-one's using
     * it, then free up the relevant structures and hash table entries.
     */

    if (TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, arrayPtr);
	return NULL;
    }

    return varPtr;
}











































































































































































































|















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137

    if (varPtr == NULL) {
	return NULL;
    }

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
		TCL_TRACE_READS, /* leaveErrMsg */ 0);
    }

    /*
     * If the variable doesn't exist anymore and no-one's using
     * it, then free up the relevant structures and hash table entries.
     */

    if (TclIsVarUndefined(varPtr)) {
	CleanupVar(varPtr, arrayPtr);
	return NULL;
    }

    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Internal functions for variable name object types --
 *
 *----------------------------------------------------------------------
 */

/* 
 * localVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the corresponding Proc 
 *   twoPtrValue.ptr2 = index into locals table
*/

static void 
FreeLocalVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
    procPtr->refCount--;
    if (procPtr->refCount <= 0) {
	TclProcCleanupProc(procPtr);
    }
}

static void
DupLocalVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;

    dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
    dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2;
    procPtr->refCount++;
    dupPtr->typePtr = &tclLocalVarNameType;
}

static void
UpdateLocalVarName(objPtr)
    Tcl_Obj *objPtr;
{
    Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
    unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2;
    CompiledLocal *localPtr = procPtr->firstLocalPtr;
    unsigned int nameLen;

    if (localPtr == NULL) {
	goto emptyName;
    }
    while (index--) {
	localPtr = localPtr->nextPtr;
	if (localPtr == NULL) {
	    goto emptyName;
	}
    }

    nameLen = (unsigned int) localPtr->nameLength;
    objPtr->bytes = ckalloc(nameLen + 1);
    memcpy(objPtr->bytes, localPtr->name, nameLen + 1);
    objPtr->length = nameLen;
    return;

    emptyName:
    objPtr->bytes = ckalloc(1);
    *(objPtr->bytes) = '\0';
    objPtr->length = 0;
}

/* 
 * nsVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1: pointer to the namespace containing the 
 *                     reference.
 *   twoPtrValue.ptr2: pointer to the corresponding Var 
*/

static void 
FreeNsVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;

    varPtr->refCount--;
    if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) {
	if (TclIsVarLink(varPtr)) {
	    Var *linkPtr = varPtr->value.linkPtr;
	    linkPtr->refCount--;
	    if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) {
		CleanupVar(linkPtr, (Var *) NULL);
	    }
	}
	CleanupVar(varPtr, NULL);
    }
}

static void
DupNsVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1;
    register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2;

    dupPtr->internalRep.twoPtrValue.ptr1 =  (VOID *) nsPtr;
    dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
    varPtr->refCount++;
    dupPtr->typePtr = &tclNsVarNameType;
}

/* 
 * parsedVarName -
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj
 *                      (NULL if scalar)
 *   twoPtrValue.ptr2 = pointer to the element name string
 *                      (owned by this Tcl_Obj), or NULL if 
 *                      it is a scalar variable
 */

static void 
FreeParsedVarName(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_Obj *arrayPtr =
	    (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
    register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;
    
    if (arrayPtr != NULL) {
	TclDecrRefCount(arrayPtr);
	ckfree(elem);
    }
}

static void
DupParsedVarName(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    register Tcl_Obj *arrayPtr =
	    (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1;
    register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
    char *elemCopy;
    unsigned int elemLen;

    if (arrayPtr != NULL) {
	Tcl_IncrRefCount(arrayPtr);
	elemLen = strlen(elem);
	elemCopy = ckalloc(elemLen+1);
	memcpy(elemCopy, elem, elemLen);
	*(elemCopy + elemLen) = '\0';
	elem = elemCopy;
    }

    dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr;
    dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem;
    dupPtr->typePtr = &tclParsedVarNameType;
}

static void
UpdateParsedVarName(objPtr)
    Tcl_Obj *objPtr;
{
    Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
    char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
    char *part1, *p;
    int len1, len2, totalLen;

    if (arrayPtr == NULL) {
	/*
	 * This is a parsed scalar name: what is it
	 * doing here?
	 */
	panic("ERROR: scalar parsedVarName without a string rep.\n");
    }
    part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
    len2 = strlen(part2);
	
    totalLen = len1 + len2 + 2;
    p = ckalloc((unsigned int) totalLen + 1);
    objPtr->bytes = p;
    objPtr->length = totalLen;

    memcpy(p, part1, (unsigned int) len1);
    p += len1;
    *p++ = '(';
    memcpy(p, part2, (unsigned int) len2);
    p += len2;
    *p++ = ')';
    *p   = '\0';
}
Changes to library/auto.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.8 2001/08/27 02:14:08 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.
#





|







1
2
3
4
5
6
7
8
9
10
11
12
13
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.8.8.1 2002/08/20 20:25:27 das Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
56
57
58
59
60
61
62

63
64
65
66
67
68
69
70
    global env errorInfo

    set dirs {}
    set errors {}

    # The C application may have hardwired a path, which we honor
    

    if {[info exists the_library] && [string compare $the_library {}]} {
	lappend dirs $the_library
    } else {

	# Do the canonical search

	# 1. From an environment variable, if it exists








>
|







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
    global env errorInfo

    set dirs {}
    set errors {}

    # The C application may have hardwired a path, which we honor
    
    set variableSet [info exists the_library]
    if {$variableSet && [string compare $the_library {}]} {
	lappend dirs $the_library
    } else {

	# Do the canonical search

	# 1. From an environment variable, if it exists

107
108
109
110
111
112
113



114
115
116
117
118
119
120
        if {[interp issafe] || [file exists $file]} {
            if {![catch {uplevel #0 [list source $file]} msg]} {
                return
            } else {
                append errors "$file: $msg\n$errorInfo\n"
            }
        }



    }
    set msg "Can't find a usable $initScript in the following directories: \n"
    append msg "    $dirs\n\n"
    append msg "$errors\n\n"
    append msg "This probably means that $basename wasn't installed properly.\n"
    error $msg
}







>
>
>







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
        if {[interp issafe] || [file exists $file]} {
            if {![catch {uplevel #0 [list source $file]} msg]} {
                return
            } else {
                append errors "$file: $msg\n$errorInfo\n"
            }
        }
    }
    if {!$variableSet} {
	unset the_library
    }
    set msg "Can't find a usable $initScript in the following directories: \n"
    append msg "    $dirs\n\n"
    append msg "$errors\n\n"
    append msg "This probably means that $basename wasn't installed properly.\n"
    error $msg
}
Changes to library/http/http.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

27
28
29
30
31
32
33
# http.tcl --
#
#	Client-side HTTP for GET, POST, and HEAD commands.
#	These routines can be used in untrusted code that uses 
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.39.8.2 2002/06/10 05:33:13 wolfsuit Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel
#	This version also cleans up error cases and eliminates the
#	"ioerror" status in favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element
#	to the state array.

package require Tcl 8.2
# keep this in sync with pkgIndex.tcl

package provide http 2.4.2

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}











|














>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
# http.tcl --
#
#	Client-side HTTP for GET, POST, and HEAD commands.
#	These routines can be used in untrusted code that uses 
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.39.8.3 2002/08/20 20:25:27 das Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel
#	This version also cleans up error cases and eliminates the
#	"ioerror" status in favor of raising an error
# 2.4	Added -binary option to http::geturl and charset element
#	to the state array.

package require Tcl 8.2
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
package provide http 2.4.2

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
Changes to library/init.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.49.8.1 2002/02/05 02:22:01 wolfsuit Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.





|







1
2
3
4
5
6
7
8
9
10
11
12
13
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.49.8.2 2002/08/20 20:25:27 das Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
26
27
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42
43
44
45
46
47


48
49
50
51
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
# tcl_library, which is the directory containing this init.tcl script.
# tclInitScript.h searches around for the directory containing this
# init.tcl and defines tcl_library to that location before sourcing it.
#
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
# Also add the directory where the executable is located, plus ../lib
# relative to that path.

#
# tcl_pkgPath, which is set by the platform-specific initialization routines
#	On UNIX it is compiled in
#       On Windows, it is not used
#	On Macintosh it is "Tool Command Language" in the Extensions folder

if {![info exists auto_path]} {
    if {[info exist env(TCLLIBPATH)]} {
	set auto_path $env(TCLLIBPATH)
    } else {
	set auto_path ""
    }
}


if {[string compare [info library] {}]} {
    foreach __dir [list [info library] [file dirname [info library]]] {
	if {[lsearch -exact $auto_path $__dir] < 0} {
	    lappend auto_path $__dir
	}
    }
}
set __dir [file join [file dirname [file dirname \
	[info nameofexecutable]]] lib]
if {[lsearch -exact $auto_path $__dir] < 0} {
    lappend auto_path $__dir
}
if {[info exist tcl_pkgPath]} {
    foreach __dir $tcl_pkgPath {
	if {[lsearch -exact $auto_path $__dir] < 0} {
	    lappend auto_path $__dir
	}
    }
}
if {[info exists __dir]} {
    unset __dir
}
  
# Windows specific end of initialization

if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
    namespace eval tcl {
	proc envTraceProc {lo n1 n2 op} {
	    set x $::env($n2)
	    set ::env($lo) $x
	    set ::env([string toupper $lo]) $x
	}
    }

    foreach p [array names env] {
	set u [string toupper $p]
	if {[string compare $u $p]} {
	    switch -- $u {
		COMSPEC -
		PATH {
		    if {![info exists env($u)]} {
			set env($u) $env($p)
		    }
		    trace variable env($p) w [list tcl::envTraceProc $p]

		    trace variable env($u) w [list tcl::envTraceProc $p]

		}
	    }
	}
    }
    if {[info exists p]} {
	unset p
    }
    if {[info exists u]} {
	unset u
    }
    if {![info exists env(COMSPEC)]} {
	if {[string equal $tcl_platform(os) "Windows NT"]} {
	    set env(COMSPEC) cmd.exe
	} else {
	    set env(COMSPEC) command.com
	}



    }
}

# Setup the unknown package handler

package unknown tclPkgUnknown








|
|
>













>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<






|




|
>
|
|
|
|
|
|
|
|
|
|
>
|
>
|
|
|
|
<
<
<
<
<
<
|
|
|
|
|
|
>
>
>







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69


70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99






100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
# tcl_library, which is the directory containing this init.tcl script.
# tclInitScript.h searches around for the directory containing this
# init.tcl and defines tcl_library to that location before sourcing it.
#
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
# Also add the directory ../lib relative to the directory where the
# executable is located.  This is meant to find binary packages for the
# same architecture as the current executable.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
#	On UNIX it is compiled in
#       On Windows, it is not used
#	On Macintosh it is "Tool Command Language" in the Extensions folder

if {![info exists auto_path]} {
    if {[info exist env(TCLLIBPATH)]} {
	set auto_path $env(TCLLIBPATH)
    } else {
	set auto_path ""
    }
}
namespace eval tcl {
    variable Dir
    if {[string compare [info library] {}]} {
	foreach Dir [list [info library] [file dirname [info library]]] {
	    if {[lsearch -exact $::auto_path $Dir] < 0} {
		lappend ::auto_path $Dir
	    }
	}
    }
    set Dir [file join [file dirname [file dirname \
	    [info nameofexecutable]]] lib]
    if {[lsearch -exact $::auto_path $Dir] < 0} {
	lappend ::auto_path $Dir
    }
    if {[info exist ::tcl_pkgPath]} {
	foreach Dir $::tcl_pkgPath {
	    if {[lsearch -exact $::auto_path $Dir] < 0} {
		lappend ::auto_path $Dir
	    }
	}
    }


}
  
# Windows specific end of initialization

if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
    namespace eval tcl {
	proc EnvTraceProc {lo n1 n2 op} {
	    set x $::env($n2)
	    set ::env($lo) $x
	    set ::env([string toupper $lo]) $x
	}
	proc InitWinEnv {} {
	    global env tcl_platform
	    foreach p [array names env] {
		set u [string toupper $p]
		if {[string compare $u $p]} {
		    switch -- $u {
			COMSPEC -
			PATH {
			    if {![info exists env($u)]} {
				set env($u) $env($p)
			    }
			    trace variable env($p) w \
				    [namespace code [list EnvTraceProc $p]]
			    trace variable env($u) w \
				    [namespace code [list EnvTraceProc $p]]
			}
		    }
		}
	    }






	    if {![info exists env(COMSPEC)]} {
		if {[string equal $tcl_platform(os) "Windows NT"]} {
		    set env(COMSPEC) cmd.exe
		} else {
		    set env(COMSPEC) command.com
		}
	    }
	}
	InitWinEnv
    }
}

# Setup the unknown package handler

package unknown tclPkgUnknown

630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
	}
    }
    return ""
}

}

namespace eval tcl {}

# ::tcl::CopyDirectory --
#
# This procedure is called by Tcl's core when attempts to call the
# filesystem's copydirectory function fail.  The semantics of the call
# are that 'dest' does not yet exist, i.e. dest should become the exact
# image of src.  If dest does exist, we throw an error.  
# 
# Note that making changes to this procedure can change the results
# of running Tcl's tests.
#
# Arguments: 
# action -              "renaming" or "copying" 
# src -			source directory
# dest -		destination directory
proc ::tcl::CopyDirectory {action src dest} {
    set nsrc [file normalize $src]
    set ndest [file normalize $dest]
    if {[string equal $action "renaming"]} {
	# Can't rename volumes.  We could give a more precise
	# error message here, but that would break the test suite.
	if {[lsearch -exact [file volumes] $nsrc] != -1} {
	    return -code error "error $action \"$src\" to\







<
<














|







631
632
633
634
635
636
637


638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
	}
    }
    return ""
}

}



# ::tcl::CopyDirectory --
#
# This procedure is called by Tcl's core when attempts to call the
# filesystem's copydirectory function fail.  The semantics of the call
# are that 'dest' does not yet exist, i.e. dest should become the exact
# image of src.  If dest does exist, we throw an error.  
# 
# Note that making changes to this procedure can change the results
# of running Tcl's tests.
#
# Arguments: 
# action -              "renaming" or "copying" 
# src -			source directory
# dest -		destination directory
proc tcl::CopyDirectory {action src dest} {
    set nsrc [file normalize $src]
    set ndest [file normalize $dest]
    if {[string equal $action "renaming"]} {
	# Can't rename volumes.  We could give a more precise
	# error message here, but that would break the test suite.
	if {[lsearch -exact [file volumes] $nsrc] != -1} {
	    return -code error "error $action \"$src\" to\
Changes to library/msgcat/msgcat.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15


16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
































































































































32
33
34
35
36
37
38
# msgcat.tcl --
#
#	This file defines various procedures which implement a
#	message catalog facility for Tcl programs.  It should be
#	loaded with the command "package require msgcat".
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: msgcat.tcl,v 1.11.8.1 2002/06/10 05:33:14 wolfsuit Exp $

package require Tcl 8.2


package provide msgcat 1.2.3

namespace eval msgcat {
    namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
	    mcunknown

    # Records the current locale as passed to mclocale
    variable locale ""

    # Records the list of locales to search
    variable loclist {}

    # Records the mapping between source strings and translated strings.  The
    # array key is of the form "<locale>,<namespace>,<src>" and the value is
    # the translated string.
    array set msgs {}
































































































































}

# msgcat::mc --
#
#	Find the translation for the given string based on the current
#	locale setting. Check the local namespace first, then look in each
#	parent namespace until the source is found.  If additional args are












|


>
>
|






|


|




|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
# msgcat.tcl --
#
#	This file defines various procedures which implement a
#	message catalog facility for Tcl programs.  It should be
#	loaded with the command "package require msgcat".
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: msgcat.tcl,v 1.11.8.2 2002/08/20 20:25:27 das Exp $

package require Tcl 8.2
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.3

namespace eval msgcat {
    namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
	    mcunknown

    # Records the current locale as passed to mclocale
    variable Locale ""

    # Records the list of locales to search
    variable Loclist {}

    # Records the mapping between source strings and translated strings.  The
    # array key is of the form "<locale>,<namespace>,<src>" and the value is
    # the translated string.
    array set Msgs {}

    # Map of language codes used in Windows registry to those of ISO-639
    array set WinRegToISO639 {
        01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
              1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
              2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
              4001 ar_QA
        02 bg 0402 bg_BG
        03 ca 0403 ca_ES
        04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO
        05 cs 0405 cs_CZ
        06 da 0406 da_DK
        07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI
        08 el 0408 el_GR
        09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ
              1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ
              2c09 en_TT 3009 en_ZW 3409 en_PH
        0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR
              180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE
              2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY
              400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR
        0b fi 040b fi_FI
        0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU
              180c fr_MC
        0d he 040d he_IL
        0e hu 040e hu_HU
        0f is 040f is_IS
        10 it 0410 it_IT 0810 it_CH
        11 ja 0411 ja_JP
        12 ko 0412 ko_KR
        13 nl 0413 nl_NL 0813 nl_BE
        14 no 0414 no_NO 0814 nn_NO
        15 pl 0415 pl_PL
        16 pt 0416 pt_BR 0816 pt_PT
        17 rm 0417 rm_CH
        18 ro 0418 ro_RO
        19 ru
        1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic
        1b sk 041b sk_SK
        1c sq 041c sq_AL
        1d sv 041d sv_SE 081d sv_FI
        1e th 041e th_TH
        1f tr 041f tr_TR
        20 ur 0420 ur_PK 0820 ur_IN
        21 id 0421 id_ID
        22 uk 0422 uk_UA
        23 be 0423 be_BY
        24 sl 0424 sl_SI
        25 et 0425 et_EE
        26 lv 0426 lv_LV
        27 lt 0427 lt_LT
        28 tg 0428 tg_TJ
        29 fa 0429 fa_IR
        2a vi 042a vi_VN
        2b hy 042b hy_AM
        2c az 042c az_AZ@latin 082c az_AZ@cyrillic
        2d eu
        2e wen 042e wen_DE
        2f mk 042f mk_MK
        30 bnt 0430 bnt_TZ
        31 ts 0431 ts_ZA
        33 ven 0433 ven_ZA
        34 xh 0434 xh_ZA
        35 zu 0435 zu_ZA
        36 af 0436 af_ZA
        37 ka 0437 ka_GE
        38 fo 0438 fo_FO
        39 hi 0439 hi_IN
        3a mt 043a mt_MT
        3b se 043b se_NO
        043c gd_UK 083c ga_IE
        3d yi 043d yi_IL
        3e ms 043e ms_MY 083e ms_BN
        3f kk 043f kk_KZ
        40 ky 0440 ky_KG
        41 sw 0441 sw_KE
        42 tk 0442 tk_TM
        43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic
        44 tt 0444 tt_RU
        45 bn 0445 bn_IN
        46 pa 0446 pa_IN
        47 gu 0447 gu_IN
        48 or 0448 or_IN
        49 ta
        4a te 044a te_IN
        4b kn 044b kn_IN
        4c ml 044c ml_IN
        4d as 044d as_IN
        4e mr 044e mr_IN
        4f sa 044f sa_IN
        50 mn
        51 bo 0451 bo_CN
        52 cy 0452 cy_GB
        53 km 0453 km_KH
        54 lo 0454 lo_LA
        55 my 0455 my_MM
        56 gl 0456 gl_ES
        57 kok 0457 kok_IN
        58 mni 0458 mni_IN
        59 sd
        5a syr 045a syr_TR
        5b si 045b si_LK
        5c chr 045c chr_US
        5d iu 045d iu_CA
        5e am 045e am_ET
        5f ber 045f ber_MA
        60 ks 0460 ks_PK 0860 ks_IN
        61 ne 0461 ne_NP 0861 ne_IN
        62 fy 0462 fy_NL
        63 ps
        64 tl 0464 tl_PH
        65 div 0465 div_MV
        66 bin 0466 bin_NG
        67 ful 0467 ful_NG
        68 ha 0468 ha_NG
        69 nic 0469 nic_NG
        6a yo 046a yo_NG
        70 ibo 0470 ibo_NG
        71 kau 0471 kau_NG
        72 om 0472 om_ET
        73 ti 0473 ti_ET
        74 gn 0474 gn_PY
        75 cpe 0475 cpe_US
        76 la 0476 la_VA
        77 so 0477 so_SO
        78 sit 0478 sit_CN
        79 pap 0479 pap_AN
    }
}

# msgcat::mc --
#
#	Find the translation for the given string based on the current
#	locale setting. Check the local namespace first, then look in each
#	parent namespace until the source is found.  If additional args are
47
48
49
50
51
52
53
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
#	Returns the translatd string.  Propagates errors thrown by the 
#	format command.

proc msgcat::mc {src args} {
    # Check for the src in each namespace starting from the local and
    # ending in the global.

    variable msgs
    variable loclist
    variable locale

    set ns [uplevel 1 [list ::namespace current]]
    
    while {$ns != ""} {
	foreach loc $loclist {
	    if {[info exists msgs($loc,$ns,$src)]} {
		if {[llength $args] == 0} {
		    return $msgs($loc,$ns,$src)
		} else {
		    return [uplevel 1 \
			    [linsert $args 0 ::format $msgs($loc,$ns,$src)]]
		}
	    }
	}
	set ns [namespace parent $ns]
    }
    # we have not found the translation
    return [uplevel 1 \
	    [linsert $args 0 [::namespace origin mcunknown] $locale $src]]
}

# msgcat::mclocale --
#
#	Query or set the current locale.
#
# Arguments:
#	newLocale	(Optional) The new locale string. Locale strings
#			should be composed of one or more sublocale parts
#			separated by underscores (e.g. en_US).
#
# Results:
#	Returns the current locale.

proc msgcat::mclocale {args} {
    variable loclist
    variable locale
    set len [llength $args]

    if {$len > 1} {
	error {wrong # args: should be "mclocale ?newLocale?"}
    }

    if {$len == 1} {
	set locale [string tolower [lindex $args 0]]
	set loclist {}
	set word ""
	foreach part [split $locale _] {
	    set word [string trimleft "${word}_${part}" _]
	    set loclist [linsert $loclist 0 $word]
	}
    }
    return $locale
}

# msgcat::mcpreferences --
#
#	Fetch the list of locales used to look up strings, ordered from
#	most preferred to least preferred.
#
# Arguments:
#	None.
#
# Results:
#	Returns an ordered list of the locales preferred by the user.

proc msgcat::mcpreferences {} {
    variable loclist
    return $loclist
}

# msgcat::mcload --
#
#	Attempt to load message catalogs for each locale in the
#	preference list from the specified directory.
#







|
|
|




|
|

|


|







|















|
|







|
|

|

|


|














|
|







177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
#	Returns the translatd string.  Propagates errors thrown by the 
#	format command.

proc msgcat::mc {src args} {
    # Check for the src in each namespace starting from the local and
    # ending in the global.

    variable Msgs
    variable Loclist
    variable Locale

    set ns [uplevel 1 [list ::namespace current]]
    
    while {$ns != ""} {
	foreach loc $Loclist {
	    if {[info exists Msgs($loc,$ns,$src)]} {
		if {[llength $args] == 0} {
		    return $Msgs($loc,$ns,$src)
		} else {
		    return [uplevel 1 \
			    [linsert $args 0 ::format $Msgs($loc,$ns,$src)]]
		}
	    }
	}
	set ns [namespace parent $ns]
    }
    # we have not found the translation
    return [uplevel 1 \
	    [linsert $args 0 [::namespace origin mcunknown] $Locale $src]]
}

# msgcat::mclocale --
#
#	Query or set the current locale.
#
# Arguments:
#	newLocale	(Optional) The new locale string. Locale strings
#			should be composed of one or more sublocale parts
#			separated by underscores (e.g. en_US).
#
# Results:
#	Returns the current locale.

proc msgcat::mclocale {args} {
    variable Loclist
    variable Locale
    set len [llength $args]

    if {$len > 1} {
	error {wrong # args: should be "mclocale ?newLocale?"}
    }

    if {$len == 1} {
	set Locale [string tolower [lindex $args 0]]
	set Loclist {}
	set word ""
	foreach part [split $Locale _] {
	    set word [string trimleft "${word}_${part}" _]
	    set Loclist [linsert $Loclist 0 $word]
	}
    }
    return $Locale
}

# msgcat::mcpreferences --
#
#	Fetch the list of locales used to look up strings, ordered from
#	most preferred to least preferred.
#
# Arguments:
#	None.
#
# Results:
#	Returns an ordered list of the locales preferred by the user.

proc msgcat::mcpreferences {} {
    variable Loclist
    return $Loclist
}

# msgcat::mcload --
#
#	Attempt to load message catalogs for each locale in the
#	preference list from the specified directory.
#
160
161
162
163
164
165
166
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
#	dest		(Optional) The translated string.  If omitted,
#			the source string is used.
#
# Results:
#	Returns the new locale.

proc msgcat::mcset {locale src {dest ""}} {
    variable msgs
    if {[string equal $dest ""]} {
	set dest $src
    }

    set ns [uplevel 1 [list ::namespace current]]

    set msgs([string tolower $locale],$ns,$src) $dest
    return $dest
}

# msgcat::mcmset --
#
#	Set the translation for multiple strings in a specified locale.
#
# Arguments:
#	locale		The locale to use.
#	pairs		One or more src/dest pairs (must be even length)
#
# Results:
#	Returns the number of pairs processed

proc msgcat::mcmset {locale pairs } {
    variable msgs

    set length [llength $pairs]
    if {$length % 2} {
	error {bad translation list: should be "mcmset locale {src dest ...}"}
    }
    
    set locale [string tolower $locale]
    set ns [uplevel 1 [list ::namespace current]]
    
    foreach {src dest} $pairs {
        set msgs($locale,$ns,$src) $dest
    }
    
    return $length
}

# msgcat::mcunknown --
#







|






|















|










|







290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
#	dest		(Optional) The translated string.  If omitted,
#			the source string is used.
#
# Results:
#	Returns the new locale.

proc msgcat::mcset {locale src {dest ""}} {
    variable Msgs
    if {[string equal $dest ""]} {
	set dest $src
    }

    set ns [uplevel 1 [list ::namespace current]]

    set Msgs([string tolower $locale],$ns,$src) $dest
    return $dest
}

# msgcat::mcmset --
#
#	Set the translation for multiple strings in a specified locale.
#
# Arguments:
#	locale		The locale to use.
#	pairs		One or more src/dest pairs (must be even length)
#
# Results:
#	Returns the number of pairs processed

proc msgcat::mcmset {locale pairs } {
    variable Msgs

    set length [llength $pairs]
    if {$length % 2} {
	error {bad translation list: should be "mcmset locale {src dest ...}"}
    }
    
    set locale [string tolower $locale]
    set ns [uplevel 1 [list ::namespace current]]
    
    foreach {src dest} $pairs {
        set Msgs($locale,$ns,$src) $dest
    }
    
    return $length
}

# msgcat::mcunknown --
#
248
249
250
251
252
253
254
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

        if {$len>$max} {
            set max $len
        }
    }
    return $max
}

# Initialize the default locale

namespace eval msgcat {
    # set default locale, try to get from environment
    if {[info exists ::env(LANG)]} {
        mclocale $::env(LANG)
    } else {
        if { $tcl_platform(platform) == "windows" } {
            # try to set locale depending on registry settings
            #




            set key {HKEY_CURRENT_USER\Control Panel\International}
            if {[catch {package require registry}] || \
		    [catch {registry get $key "locale"} locale]} {
                mclocale "C"



            } else {


		





                #
                # Clean up registry value for translating LCID value
                # by using only the last 2 digits, since first
                # 2 digits appear to be the country...  For example
                #     0409 - English - United States
                #     0809 - English - United Kingdom
                #
                set locale [string trimleft $locale "0"]
                set locale [string range $locale end-1 end]



                set locale [string tolower $locale]
                switch -- $locale {
		    01      { mclocale "ar" }
		    02      { mclocale "bg" }
		    03      { mclocale "ca" }



		    04      { mclocale "zh" }
		    05      { mclocale "cs" }
		    06      { mclocale "da" }
		    07      { mclocale "de" }
		    08      { mclocale "el" }
		    09      { mclocale "en" }
		    0a      { mclocale "es" }

		    0b      { mclocale "fi" }
		    0c      { mclocale "fr" }
		    0d      { mclocale "he" }
		    0e      { mclocale "hu" }
		    0f      { mclocale "is" }
		    10      { mclocale "it" }
		    11      { mclocale "ja" }


		    12      { mclocale "ko" }
		    13      { mclocale "da" }
		    14      { mclocale "no" }

		    15      { mclocale "pl" }
		    16      { mclocale "pt" }

		    

		    default  { mclocale "C" }



		}

            }
        } else {



            mclocale "C"
        }
    }
}








|
|
|
|
|
<
<
<
<
|
>
>
>
>
|
|
|
|
>
>
>
|
>
>
|
>
>
>
>
>
|
<
<
|
|
<
|
|
<
>
>
>
|
<
|
<
|
>
>
>
|
<
<
<
|
|
<
>
|
|
|
|
|
<
<
>
>
|
|
|
>
|
|
>
|
>
|
>
>
>
|
>
|
<
>
>
>
|
|
<
<
>
378
379
380
381
382
383
384
385
386
387
388
389




390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411


412
413

414
415

416
417
418
419

420

421
422
423
424
425



426
427

428
429
430
431
432
433


434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451

452
453
454
455
456


457
        if {$len>$max} {
            set max $len
        }
    }
    return $max
}

# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
proc msgcat::ConvertLocale {value} {
    # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
    # Convert to form: $language[_$territory][_$modifier]




    #
    # Comment out expanded RE version -- bugs alleged
    # regexp -expanded {
    #	^		# Match all the way to the beginning
    #	([^_.@]*)	# Match "lanugage"; ends with _, ., or @
    #	(_([^.@]*))?	# Match (optional) "territory"; starts with _
    #	([.]([^@]*))?	# Match (optional) "codeset"; starts with .
    #	(@(.*))?	# Match (optional) "modifier"; starts with @
    #	$		# Match all the way to the end
    # } $value -> language _ territory _ codeset _ modifier
    regexp {^([^_.@]*)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
	    -> language _ territory _ codeset _ modifier
    set ret $language
    if {[string length $territory]} {
	append ret _$territory
    }
    if {[string length $modifier]} {
	append ret _$modifier
    }
    return $ret
}



# Initialize the default locale
proc msgcat::Init {} {

    #
    # set default locale, try to get from environment

    #
    foreach varName {LC_ALL LC_MESSAGES LANG} {
	if {[info exists ::env($varName)] 
		&& ![string equal "" $::env($varName)]} {

            mclocale [ConvertLocale $::env($varName)]

	    return
	}
    }
    #
    # On Windows, try to set locale depending on registry settings,



    # or fall back on locale of "C".  Other platforms will return
    # when they fail to load the registry package.

    #
    set key {HKEY_CURRENT_USER\Control Panel\International}
    if {[catch {package require registry}] \
	    || [catch {registry get $key "locale"} locale]} {
        mclocale C
	return


    }
    #
    # Keep trying to match against smaller and smaller suffixes
    # of the registry value, since the latter hexadigits appear
    # to determine general language and earlier hexadigits determine
    # more precise information, such as territory.  For example,
    #     0409 - English - United States
    #     0809 - English - United Kingdom
    # Add more translations to the WinRegToISO639 array above.
    #
    variable WinRegToISO639
    set locale [string tolower $locale]
    while {[string length $locale]} {
        if {![catch {mclocale [ConvertLocale $WinRegToISO639($locale)]}]} {
	    return
	}
	set locale [string range $locale 1 end]
    }

    #
    # No translation known.  Fall back on "C" locale
    #
    mclocale C
}


msgcat::Init
Changes to library/msgcat/pkgIndex.tcl.
1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded msgcat 1.2.3 [list source [file join $dir msgcat.tcl]]

|
1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded msgcat 1.3 [list source [file join $dir msgcat.tcl]]
Changes to library/opt/optparse.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13


14
15
16
17
18
19
20
# optparse.tcl --
#
#       (private) Option parsing package
#       Primarily used internally by the safe:: code.
#
#	WARNING: This code will go away in a future release
#	of Tcl.  It is NOT supported and you should not rely
#	on it.  If your code does rely on this package you
#	may directly incorporate this code into your application.
#
# RCS: @(#) $Id: optparse.tcl,v 1.6 2001/08/09 01:06:42 dgp Exp $

package require Tcl 8


package provide opt 0.4.3

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \










|


>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# optparse.tcl --
#
#       (private) Option parsing package
#       Primarily used internally by the safe:: code.
#
#	WARNING: This code will go away in a future release
#	of Tcl.  It is NOT supported and you should not rely
#	on it.  If your code does rely on this package you
#	may directly incorporate this code into your application.
#
# RCS: @(#) $Id: optparse.tcl,v 1.6.8.1 2002/08/20 20:25:27 das Exp $

package require Tcl 8
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.3

namespace eval ::tcl {

    # Exported APIs
    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
             OptProc OptProcArgGiven OptParse \
Changes to library/tcltest/pkgIndex.tcl.
1
2
3
4
5
6
7
8
9
10
11
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.1 [list source [file join $dir tcltest.tcl]]











|
1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded tcltest 2.2 [list source [file join $dir tcltest.tcl]]
Changes to library/tcltest/tcltest.tcl.
9
10
11
12
13
14
15

16
17
18
19

20
21



22





23

24

25

26



27

28


29




30
31

32




33
34



35

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
#       This design was based on the Tcl testing approach designed and
#       initially implemented by Mary Ann May-Pumphrey of Sun
#	Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions

# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.33.8.1 2002/06/10 05:33:14 wolfsuit Exp $


# create the "tcltest" namespace for all testing variables and
# procedures









package require Tcl 8.3



namespace eval tcltest {





    # Export the public tcltest procs

    namespace export bytestring cleanupTests customMatch debug errorChannel \


	    errorFile interpreter limitConstraints loadFile loadScript \




	    loadTestedCommands makeDirectory makeFile match \
	    matchDirectories matchFiles normalizeMsg normalizePath \

	    outputChannel outputFile preserveCore removeDirectory \




	    removeFile runAllTests singleProcess skip skipDirectories \
	    skipFiles temporaryDirectory test testConstraint \



	    testsDirectory verbose viewFile workingDirectory

    # Export the tcltest 1 compatibility procs
    namespace export getMatchingFiles mainThread restoreState saveState \
	    threadReap

    proc Default {varName value} {
	variable $varName
	if {![info exists $varName]} {
	    variable $varName $value
	}
    }
    proc ArrayDefault {varName value} {
	variable $varName
	if {[array exists $varName]} {
	    return
	}
	if {[info exists $varName]} {
	    # Pre-initialized value is a scalar: destroy it!
	    unset $varName
	}
	array set $varName $value
    }

    # verbose defaults to {body}
    Default verbose body

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the
    # testsDirectory and matchDirectories, which defaults to all
    # directories.
    Default match {}
    Default skip {}
    Default matchFiles {*.test}
    Default skipFiles {}
    Default matchDirectories {*}
    Default skipDirectories {}

    # By default, don't save core files
    Default preserveCore 0

    # output goes to stdout by default
    Default outputChannel stdout
    Default outputFile stdout

    # errors go to stderr by default
    Default errorChannel stderr
    Default errorFile stderr

    # debug output doesn't get printed by default; debug level 1 spits
    # up only the tests that were skipped because they didn't match or
    # were specifically skipped.  A debug level of 2 would spit up the
    # tcltest variables and flags provided; a debug level of 3 causes
    # some additional output regarding operations of the test harness.
    # The tcltest package currently implements only up to debug level 3.
    Default debug 0

    # Save any arguments that we might want to pass through to other
    # programs.  This is used by the -args flag.
    Default parameters {}

    # Count the number of files tested (0 if runAllTests wasn't called).
    # runAllTests will set testSingleFile to false, so stats will
    # not be printed until runAllTests calls the cleanupTests proc.
    # The currentFailure var stores the boolean value of whether the
    # current test file has had any failures.  The failFiles list
    # stores the names of test files that had failures.
    Default numTestFiles 0
    Default testSingleFile true
    Default currentFailure false
    Default failFiles {}

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # filesMade keeps track of such files created using the makeFile and
    # makeDirectory procedures.  filesExisted stores the names of
    # pre-existing files.
    Default filesMade {}
    Default filesExisted {}

    # numTests will store test files as indices and the list of files
    # (that should not have been) left behind by the test files.
    ArrayDefault createdNewFiles {}

    # initialize numTests array to keep track fo the number of tests
    # that pass, fail, and are skipped.
    ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # initialize skippedBecause array to keep track of constraints that
    # kept tests from running; a constraint name of "userSpecifiedSkip"
    # means that the test appeared on the list of tests that matched the
    # -skip value given to the flag; "userSpecifiedNonMatch" means that
    # the test didn't match the argument given to the -match flag; both
    # of these constraints are counted only if tcltest::debug is set to
    # true.
    ArrayDefault skippedBecause {}

    # initialize the testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # InitConstraints proc for more details).
    ArrayDefault testConstraints {}
    Default ConstraintsSpecifiedByCommandLineArgument {}

    # Kept only for compatibility
    Default constraintsSpecified {}
    trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
		[array names ::tcltest::testConstraints] ;# }

    # Don't run only the "-constraint" specified tests by default
    Default limitConstraints false

    # A test application has to know how to load the tested commands
    # into the interpreter.
    Default loadScript {}

    # and the filename of the script file, if it exists
    Default loadFile {}

    # tests that use threads need to know which is the main thread
    Default mainThread 1
    variable mainThread
    if {[info commands thread::id] != {}} {
	set mainThread [thread::id]
    } elseif {[info commands testthread] != {}} {
	set mainThread [testthread id]
    }

    # save the original environment so that it can be restored later
    ArrayDefault originalEnv [array get ::env]

    # Set workingDirectory to [pwd]. The default output directory for
    # Tcl tests is the working directory.
    Default workingDirectory [pwd]
    Default temporaryDirectory $workingDirectory

    # tcltest::normalizePath --
    #
    #     This procedure resolves any symlinks in the path thus creating
    #     a path without internal redirection. It assumes that the
    #     incoming path is absolute.
    #
    # Arguments
    #     pathVar contains the name of the variable containing the path
    #     to modify.
    #
    # Results
    #     The path is modified in place.
    #
    # Side Effects:
    #     None.
    #
    proc normalizePath {pathVar} {
	upvar $pathVar path
	set oldpwd [pwd]
	catch {cd $path}
	set path [pwd]
	cd $oldpwd
	return $path
    }







    # Tests should not rely on the current working directory.




    # Files that are part of the test suite should be accessed relative




    # to tcltest::testsDirectory.




















    Default testsDirectory [file join \

	    [file dirname [info script]] .. .. tests]
























    variable testsDirectory









    normalizePath testsDirectory






































    # Default is to run each test file in a separate process

















































































    Default singleProcess 0





    # the variables and procs that existed when saveState was called are
    # stored in a variable of the same name
    Default saveState {}

    # Internationalization support -- used in [SetIso8859_1_Locale] and
    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {
	variable isoLocale fr
	switch -- $tcl_platform(platform) {
	    "unix" {

		# Try some 'known' values for some platforms:

		switch -exact -- $tcl_platform(os) {
		    "FreeBSD" {
			set isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set isoLocale fr_FR.iso88591
		    }
		    Linux -







>


|

>
|
|
>
>
>

>
>
>
>
>
|
>
|
>
|
>

>
>
>
|
>
|
>
>
|
>
>
>
>
|
|
>
|
>
>
>
>
|
|
>
>
>
|
>
|



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







|
<
















>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>










|




|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

































































































































72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
#       This design was based on the Tcl testing approach designed and
#       initially implemented by Mary Ann May-Pumphrey of Sun
#	Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.33.8.2 2002/08/20 20:25:27 das Exp $

package require Tcl 8.3		;# uses [glob -directory]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.
    variable Version 2.2

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

##### Export the public tcltest procs; several categories
    #
    # Export the main functional commands that do useful things
    namespace export cleanupTests loadTestedCommands makeDirectory \
	makeFile removeDirectory removeFile runAllTests test

    # Export configuration commands that control the functional commands
    namespace export configure customMatch errorChannel interpreter \
	    outputChannel testConstraint

    # Export commands that are duplication (candidates for deprecation)
    namespace export bytestring		;# dups [encoding convertfrom identity]
    namespace export debug		;#	[configure -debug]
    namespace export errorFile		;#	[configure -errfile]
    namespace export limitConstraints	;#	[configure -limitconstraints]
    namespace export loadFile		;#	[configure -loadfile]
    namespace export loadScript		;#	[configure -load]
    namespace export match		;#	[configure -match]
    namespace export matchFiles		;#	[configure -file]
    namespace export matchDirectories	;#	[configure -relateddir]
    namespace export normalizeMsg	;#	application of [customMatch]
    namespace export normalizePath	;#	[file normalize] (8.4)
    namespace export outputFile		;#	[configure -outfile]
    namespace export preserveCore	;#	[configure -preservecore]
    namespace export singleProcess	;#	[configure -singleproc]
    namespace export skip		;#	[configure -skip]
    namespace export skipFiles		;#	[configure -notfile]
    namespace export skipDirectories	;#	[configure -asidefromdir]
    namespace export temporaryDirectory	;#	[configure -tmpdir]
    namespace export testsDirectory	;#	[configure -testdir]
    namespace export verbose		;#	[configure -verbose]
    namespace export viewFile		;#	binary encoding [read]
    namespace export workingDirectory	;#	[cd] [pwd]

    # Export deprecated commands for tcltest 1 compatibility
    namespace export getMatchingFiles mainThread restoreState saveState \
	    threadReap


































































































































    # tcltest::normalizePath --
    #
    #     This procedure resolves any symlinks in the path thus creating
    #     a path without internal redirection. It assumes that the
    #     incoming path is absolute.
    #
    # Arguments
    #     pathVar - name of variable containing path to modify.

    #
    # Results
    #     The path is modified in place.
    #
    # Side Effects:
    #     None.
    #
    proc normalizePath {pathVar} {
	upvar $pathVar path
	set oldpwd [pwd]
	catch {cd $path}
	set path [pwd]
	cd $oldpwd
	return $path
    }

##### Verification commands used to test values of variables and options
    #
    # Verification command that accepts everything
    proc AcceptAll {value} {
	return $value
    }

    # Verification command that accepts valid Tcl lists
    proc AcceptList { list } {
	return [lrange $list 0 end]
    }

    # Verification command that accepts a glob pattern
    proc AcceptPattern { pattern } {
	return [AcceptAll $pattern]
    }

    # Verification command that accepts integers
    proc AcceptInteger { level } {
	return [incr level 0]
    }

    # Verification command that accepts boolean values
    proc AcceptBoolean { boolean } {
	return [expr {$boolean && $boolean}]
    }

    # Verification command that accepts (syntactically) valid Tcl scripts
    proc AcceptScript { script } {
	if {![info complete $script]} {
	    return -code error "invalid Tcl script: $script"
	}
	return $script
    }

    # Verification command that accepts (converts to) absolute pathnames
    proc AcceptAbsolutePath { path } {
	return [file join [pwd] $path]
    }

    # Verification command that accepts existing readable directories
    proc AcceptReadable { path } {
	if {![file readable $path]} {
	    return -code error "\"$path\" is not readable"
	}
	return $path
    }
    proc AcceptDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    return -code error "\"$directory\" does not exist"
	}
	if {![file isdir $directory]} {
	    return -code error "\"$directory\" is not a directory"
	}
	return [AcceptReadable $directory]
    }

##### Initialize internal arrays of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc ArrayDefault {varName value} {
	variable $varName
	if {[array exists $varName]} {
	    return
	}
	if {[info exists $varName]} {
	    # Pre-initialized value is a scalar: destroy it!
	    unset $varName
	}
	array set $varName $value
    }

    # save the original environment so that it can be restored later
    ArrayDefault originalEnv [array get ::env]

    # initialize numTests array to keep track fo the number of tests
    # that pass, fail, and are skipped.
    ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # numTests will store test files as indices and the list of files
    # (that should not have been) left behind by the test files.
    ArrayDefault createdNewFiles {}

    # initialize skippedBecause array to keep track of constraints that
    # kept tests from running; a constraint name of "userSpecifiedSkip"
    # means that the test appeared on the list of tests that matched the
    # -skip value given to the flag; "userSpecifiedNonMatch" means that
    # the test didn't match the argument given to the -match flag; both
    # of these constraints are counted only if tcltest::debug is set to
    # true.
    ArrayDefault skippedBecause {}

    # initialize the testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # InitConstraints proc for more details).
    ArrayDefault testConstraints {}

##### Initialize internal variables of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc Default {varName value {verify AcceptAll}} {
	variable $varName
	if {![info exists $varName]} {
	    variable $varName [$verify $value]
	} else {
	    variable $varName [$verify [set $varName]]
	}
    }

    # Save any arguments that we might want to pass through to other
    # programs.  This is used by the -args flag.
    # FINDUSER
    Default parameters {}

    # Count the number of files tested (0 if runAllTests wasn't called).
    # runAllTests will set testSingleFile to false, so stats will
    # not be printed until runAllTests calls the cleanupTests proc.
    # The currentFailure var stores the boolean value of whether the
    # current test file has had any failures.  The failFiles list
    # stores the names of test files that had failures.
    Default numTestFiles 0 AcceptInteger
    Default testSingleFile true AcceptBoolean
    Default currentFailure false AcceptBoolean
    Default failFiles {} AcceptList

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # filesMade keeps track of such files created using the makeFile and
    # makeDirectory procedures.  filesExisted stores the names of
    # pre-existing files.
    Default filesMade {} AcceptList
    Default filesExisted {} AcceptList
    variable FilesExistedFilled 0
    proc FillFilesExisted {} {
	variable FilesExistedFilled
	if {$FilesExistedFilled} {return}
	variable filesExisted

	# Save the names of files that already exist in the scratch directory.
	foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
	    lappend filesExisted [file tail $file]
	}
	set FilesExistedFilled 1
    }

    # Kept only for compatibility
    Default constraintsSpecified {} AcceptList
    trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
		[array names ::tcltest::testConstraints] ;# }

    # tests that use threads need to know which is the main thread
    Default mainThread 1
    variable mainThread
    if {[info commands thread::id] != {}} {
	set mainThread [thread::id]
    } elseif {[info commands testthread] != {}} {
	set mainThread [testthread id]
    }

    # Set workingDirectory to [pwd]. The default output directory for
    # Tcl tests is the working directory.  Whenever this value changes
    # change to that directory.
    variable workingDirectory
    trace variable workingDirectory w \
	    [namespace code {cd $workingDirectory ;#}]

    Default workingDirectory [pwd] AcceptAbsolutePath
    proc workingDirectory { {dir ""} } {
	variable workingDirectory
	if {[llength [info level 0]] == 1} {
	    return $workingDirectory
	}
	set workingDirectory [AcceptAbsolutePath $dir]
    }

    # Set the location of the execuatble
    Default tcltest [info nameofexecutable]
    trace variable tcltest w [namespace code {testConstraint stdio \
	    [eval [ConstraintInitializer stdio]] ;#}]

    # save the platform information so it can be restored later
    Default originalTclPlatform [array get ::tcl_platform]

    # If a core file exists, save its modification time.
    if {[file exists [file join [workingDirectory] core]]} {
	Default coreModTime \
		[file mtime [file join [workingDirectory] core]]
    }

    # stdout and stderr buffers for use when we want to store them
    Default outData {}
    Default errData {}

    # keep track of test level for nested test commands
    variable testLevel 0

    # the variables and procs that existed when saveState was called are
    # stored in a variable of the same name
    Default saveState {}

    # Internationalization support -- used in [SetIso8859_1_Locale] and
    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {
	variable isoLocale fr
	switch -- $::tcl_platform(platform) {
	    "unix" {

		# Try some 'known' values for some platforms:

		switch -exact -- $::tcl_platform(os) {
		    "FreeBSD" {
			set isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set isoLocale fr_FR.iso88591
		    }
		    Linux -
239
240
241
242
243
244
245




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
	    }
	    "windows" {
		set isoLocale French
	    }
	}
    }





    # Set the location of the execuatble





    Default tcltest [info nameofexecutable]














    # save the platform information so it can be restored later




    Default originalTclPlatform [array get tcl_platform]











































































    # If a core file exists, save its modification time.

    variable workingDirectory
























    if {[file exists [file join $workingDirectory core]]} {







	Default coreModTime \















		[file mtime [file join $workingDirectory core]]






    }





























    # stdout and stderr buffers for use when we want to store them

















    Default outData {}




    Default errData {}





















































































    # keep track of test level for nested test commands


















































    variable testLevel 0






























}

#####################################################################

# tcltest::Debug* --
#
#     Internal helper procedures to write out debug information







>
>
>
>
|
>
>
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
	    }
	    "windows" {
		set isoLocale French
	    }
	}
    }

    # output goes to stdout by default
    Default outputChannel stdout
    proc outputChannel { {filename ""} } {
	variable outputChannel

	# Trigger auto-configuration of -outfile option, if needed.
	# This is tricky because we have to trigger a trace on $debug
	# so that traces attached to $outputFile are not disabled.
	# We need them enabled to reflect changes back to outputChannel
	set dummy [debug]

	if {[llength [info level 0]] == 1} {
	    return $outputChannel
	}
	switch -exact -- $filename {
	    stderr -
	    stdout {
		set outputChannel $filename
	    }
	    default {
		set outputChannel [open $filename a]
	    }
	}
	return $outputChannel
    }

    # errors go to stderr by default
    Default errorChannel stderr
    proc errorChannel { {filename ""} } {
	variable errorChannel

	# Trigger auto-configuration of -errfile option, if needed.
	# This is tricky because we have to trigger a trace on $debug
	# so that traces attached to $outputFile are not disabled.
	# We need them enabled to reflect changes back to outputChannel
	set dummy [debug]

	if {[llength [info level 0]] == 1} {
	    return $errorChannel
	}
	switch -exact -- $filename {
	    stderr -
	    stdout {
		set errorChannel $filename
	    }
	    default {
		set errorChannel [open $filename a]
	    }
	}
	return $errorChannel
    }

##### Set up the configurable options
    #
    # The configurable options of the package
    variable Option; array set Option {}

    # Usage strings for those options
    variable Usage; array set Usage {}

    # Verification commands for those options
    variable Verify; array set Verify {}

    # Initialize the default values of the configurable options that are
    # historically associated with an exported variable.  If that variable
    # is already set, support compatibility by accepting its pre-set value.
    # Use [trace] to establish ongoing connection between the deprecated
    # exported variable and the modern option kept as a true internal var.
    # Also set up usage string and value testing for the option.
    proc Option {option value usage {verify AcceptAll} {varName {}}} {
	variable Option
	variable Verify
	variable Usage
	variable OptionControlledVariables
	set Usage($option) $usage
	set Verify($option) $verify
	if {[catch {$verify $value} msg]} {
	    return -code error $msg
	} else {
	    set Option($option) $msg
	}
	if {[string length $varName]} {
	    variable $varName
	    if {[info exists $varName]} {
		if {[catch {$verify [set $varName]} msg]} {
		    return -code error $msg
		} else {
		    set Option($option) $msg
		}
		unset $varName
	    }
	    namespace eval [namespace current] \
	    	    [list upvar 0 Option($option) $varName]
	    # Workaround for Bug 572889.  Grrrr....
	    # Track all the variables tied to options
	    lappend OptionControlledVariables $varName
	    # Later, set auto-configure read traces on all
	    # of them, since a single trace on Option does not work.
	    proc $varName {{value {}}} [subst -nocommands {
		if {[llength [info level 0]] == 2} {
		    Configure $option [set value]
		}
		return [Configure $option]
	    }]
	}
    }

    proc MatchingOption {option} {
	variable Option
	set match [array names Option $option*]
	switch -- [llength $match] {
	    0 {
		set sorted [lsort [array names Option]]
		set values [join [lrange $sorted 0 end-1] ", "]
		append values ", or [lindex $sorted end]"
		return -code error "unknown option $option: should be\
			one of $values"
	    }
	    1 {
		return [lindex $match 0]
	    }
	    default {
		# Exact match trumps ambiguity
		if {[lsearch -exact $match $option] >= 0} {
		    return $option
		}
		set values [join [lrange $match 0 end-1] ", "]
		append values ", or [lindex $match end]"
		return -code error "ambiguous option $option:\
			could match $values"
	    }
	}
    }

    proc EstablishAutoConfigureTraces {} {
	variable OptionControlledVariables
	foreach varName [concat $OptionControlledVariables Option] {
	    variable $varName
	    trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
	}
    }

    proc RemoveAutoConfigureTraces {} {
	variable OptionControlledVariables
	foreach varName [concat $OptionControlledVariables Option] {
	    variable $varName
	    foreach pair [trace vinfo $varName] {
		foreach {op cmd} $pair break
		if {[string equal r $op]
			&& [string match *ProcessCmdLineArgs* $cmd]} {
		    trace vdelete $varName $op $cmd
		}
	    }
	}
	# One the traces are removed, this can become a no-op
	proc RemoveAutoConfigureTraces {} {}
    }

    proc Configure args {
	variable Option
	variable Verify
	set n [llength $args]
	if {$n == 0} {
	    return [lsort [array names Option]]
	}
	if {$n == 1} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    return $Option($option)
	}
	while {[llength $args] > 1} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    if {[catch {$Verify($option) [lindex $args 1]} value]} {
		return -code error "invalid $option\
			value \"[lindex $args 1]\": $value"
	    }
	    set Option($option) $value
	    set args [lrange $args 2 end]
	}
	if {[llength $args]} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    return -code error "missing value for option $option"
	}
    }
    proc configure args {
	RemoveAutoConfigureTraces
	set code [catch {eval Configure $args} msg]
	return -code $code $msg
    }
    
    proc AcceptVerbose { level } {
	set level [AcceptList $level]
	if {[llength $level] == 1} {
	    if {![regexp {^(pass|body|skip|start|error)$} $level]} {
		# translate single characters abbreviations to expanded list
		set level [string map {p pass b body s skip t start e error} \
			[split $level {}]]
	    }
	}
	set valid [list]
	foreach v $level {
	    if {[regexp {^(pass|body|skip|start|error)$} $v]} {
		lappend valid $v
	    }
	}
	return $valid
    }

    proc IsVerbose {level} {
	variable Option
	return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
    }

    # Default verbosity is to show bodies of failed tests
    Option -verbose body {
	Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
	Test suite will display all passed tests if 'p' is specified, all
	skipped tests if 's' is specified, the bodies of failed tests if
	'b' is specified, and when tests start if 't' is specified.
	ErrorInfo is displayed if 'e' is specified.
    } AcceptVerbose verbose

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the
    # testsDirectory and matchDirectories, which defaults to all
    # directories.
    Option -match * {
	Run all tests within the specified files that match one of the
	list of glob patterns given.
    } AcceptList match

    Option -skip {} {
	Skip all tests within the specified tests (via -match) and files
	that match one of the list of glob patterns given.
    } AcceptList skip

    Option -file *.test {
	Run tests in all test files that match the glob pattern given.
    } AcceptPattern matchFiles

    # By default, skip files that appear to be SCCS lock files.
    Option -notfile l.*.test {
	Skip all test files that match the glob pattern given.
    } AcceptPattern skipFiles

    Option -relateddir * {
	Run tests in directories that match the glob pattern given.
    } AcceptPattern matchDirectories

    Option -asidefromdir {} {
	Skip tests in directories that match the glob pattern given.
    } AcceptPattern skipDirectories

    # By default, don't save core files
    Option -preservecore 0 {
	If 2, save any core files produced during testing in the directory
	specified by -tmpdir. If 1, notify the user if core files are
	created.
    } AcceptInteger preserveCore

    # debug output doesn't get printed by default; debug level 1 spits
    # up only the tests that were skipped because they didn't match or
    # were specifically skipped.  A debug level of 2 would spit up the
    # tcltest variables and flags provided; a debug level of 3 causes
    # some additional output regarding operations of the test harness.
    # The tcltest package currently implements only up to debug level 3.
    Option -debug 0 {
	Internal debug level 
    } AcceptInteger debug

    proc SetSelectedConstraints args {
	variable Option
	foreach c $Option(-constraints) {
	    testConstraint $c 1
	}
    }
    Option -constraints {} {
	Do not skip the listed constraints listed in -constraints.
    } AcceptList
    trace variable Option(-constraints) w \
	    [namespace code {SetSelectedConstraints ;#}]

    # Don't run only the "-constraint" specified tests by default
    proc ClearUnselectedConstraints args {
	variable Option
	variable testConstraints
	if {!$Option(-limitconstraints)} {return}
	foreach c [array names testConstraints] {
	    if {[lsearch -exact $Option(-constraints) $c] == -1} {
		testConstraint $c 0
	    }
	}
    }
    Option -limitconstraints false {
	whether to run only tests with the constraints
    } AcceptBoolean limitConstraints 
    trace variable Option(-limitconstraints) w \
	    [namespace code {ClearUnselectedConstraints ;#}]

    # A test application has to know how to load the tested commands
    # into the interpreter.
    Option -load {} {
	Specifies the script to load the tested commands.
    } AcceptScript loadScript

    # Default is to run each test file in a separate process
    Option -singleproc 0 {
	whether to run all tests in one process
    } AcceptBoolean singleProcess 

    proc AcceptTemporaryDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    file mkdir $directory
	}
	set directory [AcceptDirectory $directory]
	if {![file writable $directory]} {
	    if {[string equal [workingDirectory] $directory]} {
		# Special exception: accept the default value
		# even if the directory is not writable
		return $directory
	    }
	    return -code error "\"$directory\" is not writeable"
	}
	return $directory
    }

    # Directory where files should be created
    Option -tmpdir [workingDirectory] {
	Save temporary files in the specified directory.
    } AcceptTemporaryDirectory temporaryDirectory
    trace variable Option(-tmpdir) w \
	    [namespace code {normalizePath Option(-tmpdir) ;#}]

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative
    # to [testsDirectory]
    Option -testdir [workingDirectory] {
	Search tests in the specified directory.
    } AcceptDirectory testsDirectory
    trace variable Option(-testdir) w \
	    [namespace code {normalizePath Option(-testdir) ;#}]

    proc AcceptLoadFile { file } {
	if {[string equal "" $file]} {return $file}
	set file [file join [temporaryDirectory] $file]
	return [AcceptReadable $file]
    }
    proc ReadLoadScript {args} {
	variable Option
	if {[string equal "" $Option(-loadfile)]} {return}
	set tmp [open $Option(-loadfile) r]
	loadScript [read $tmp]
	close $tmp
    }
    Option -loadfile {} {
	Read the script to load the tested commands from the specified file.
    } AcceptLoadFile loadFile
    trace variable Option(-loadfile) w [namespace code ReadLoadScript]

    proc AcceptOutFile { file } {
	if {[string equal stderr $file]} {return $file}
	if {[string equal stdout $file]} {return $file}
	return [file join [temporaryDirectory] $file]
    }

    # output goes to stdout by default
    Option -outfile stdout {
	Send output from test runs to the specified file.
    } AcceptOutFile outputFile
    trace variable Option(-outfile) w \
	    [namespace code {outputChannel $Option(-outfile) ;#}]

    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace variable Option(-errfile) w \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

}

#####################################################################

# tcltest::Debug* --
#
#     Internal helper procedures to write out debug information
353
354
355
356
357
358
359
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
	uplevel 1 $script
    }
    return
}

#####################################################################

# tcltest::CheckDirectory --
#
#     This procedure checks whether the specified path is a readable
#     and/or writable directory. If one of the conditions is not
#     satisfied an error is printed and the application aborted. The
#     procedure assumes that the caller already checked the existence
#     of the path.
#
# Arguments
#     rw      Information what attributes to check. Allowed values:
#             r, w, rw, wr. If 'r' is part of the value the directory
#             must be readable. 'w' associates to 'writable'.
#     dir     The directory to check.
#     errMsg  The string to prepend to the actual error message before
#             printing it.
#
# Results
#     none
#
# Side Effects:
#     None.
#

proc tcltest::CheckDirectory {rw dir errMsg} {
    # Allowed values for 'rw': r, w, rw, wr

    if {![file isdir $dir]} {
	return -code error "$errMsg \"$dir\" is not a directory"
    } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
	return -code error "$errMsg \"$dir\" is not writeable"
    } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
	return -code error "$errMsg \"$dir\" is not readable"
    }
    return
}

# tcltest::MakeAbsolutePath --
#
#     This procedure checks whether the incoming path is absolute or
#     not.  Makes it absolute if it was not.
#
# Arguments
#     pathVar contains the name of the variable containing the path to
#             modify.
#     prefix  is optional, contains the path to use to make the other an
#             absolute one. The current working directory is used if it
#             was not specified.
#
# Results
#     The path is modified in place.
#
# Side Effects:
#     None.
#

proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
    upvar $pathVar path

    if {![string equal [file pathtype $path] "absolute"]} {
	if {[string equal {} $prefix]} {
	    set prefix [pwd]
	}

	set path [file join $prefix $path]
    }
    return $path
}

#####################################################################

# tcltest::<variableName>
#
#     Accessor functions for tcltest variables that can be modified
#     externally.  These are vars that could otherwise be modified
#     using command line arguments to tcltest.

#     Many of them are all the same boilerplate:

namespace eval tcltest {
    variable var
    foreach var {
	    match skip matchFiles skipFiles matchDirectories
	    skipDirectories preserveCore debug loadScript singleProcess
	    mainThread ConstraintsSpecifiedByCommandLineArgument
    } {
	proc $var { {new ""} } [subst -nocommands {
	    variable $var
	    if {[llength [info level 0]] == 1} {
		return [set $var]
	    }
	    set $var \$new
	}]
    }
    unset var
}

#     The rest have something special to deal with:

# tcltest::verbose --
#
#	Set or return the verbosity level (tcltest::verbose) for tests.
#       This determines what gets printed to the screen and when, with
#       regard to the running of the tests.  The proc does not check for
#       invalid values.  It assumes that a string that doesn't match its
#       predefined keywords is a string containing letter-specified
#       verbosity levels.
#
# Arguments:
#	A string containing any combination of 'pbste' or a list of
#       keywords (listed in parens)
#          p = print output whenever a test passes (pass)
#          b = print the body of the test when it fails (body)
#          s = print when a test is skipped (skip)
#          t = print when a test starts (start)
#          e = print errorInfo and errorCode when a test encounters an
#              error (error)
#
# Results:
#	content of tcltest::verbose
#
# Side effects:
#	None.

proc tcltest::verbose { {level ""} } {
    variable verbose
    if {[llength [info level 0]] == 1} {
	return $verbose
    }
    if {[llength $level] > 1} {
  	set verbose $level
    } else {
	if {[regexp {pass|body|skip|start|error} $level]} {
	    set verbose $level
	} else {
	    set levelList [split $level {}]
	    set verbose [string map \
		    {p pass b body s skip t start e error} $levelList]
	}
    }
    return $verbose
}

# tcltest::IsVerbose --
#
#	Returns true if argument is one of the verbosity levels
#       currently being used; returns false otherwise.
#
# Arguments:
#	level
#
# Results:
#	boolean 1 (true) or 0 (false), depending on whether or not the
#       level provided is one of the ones stored in tcltest::verbose.
#
# Side effects:
#	None.

proc tcltest::IsVerbose {level} {
    if {[lsearch -exact [verbose] $level] == -1} {
	return 0
    }
    return 1
}

# tcltest::outputChannel --
#
#	set or return the output file descriptor based on the supplied
#       file name (where tcltest puts all of its output)
#
# Arguments:
#	output file descriptor
#
# Results:
#	file descriptor corresponding to supplied file name (or
#       currently set file descriptor, if no new filename was supplied)
#       - this is the content of tcltest::outputChannel
#
# Side effects:
#	None.

proc tcltest::outputChannel { {filename ""} } {
    variable outputChannel
    if {[llength [info level 0]] == 1} {
	return $outputChannel
    }
    switch -exact -- $filename {
	stderr -
	stdout {
	    set outputChannel $filename
	}
	default {
	    set outputChannel [open $filename w]
	}
    }
    return $outputChannel
}

# tcltest::outputFile --
#
#	set or return the output file name (where tcltest puts all of
#       its output); calls [outputChannel] to set the corresponding
#       file descriptor
#
# Arguments:
#	output file name
#
# Results:
#       file name corresponding to supplied file name (or currently set
#       file name, if no new filename was supplied) - this is the
#       content of tcltest::outputFile
#
# Side effects:
#	if the file name supplied is relative, it will be made absolute
#       with respect to the predefined temporaryDirectory

proc tcltest::outputFile { {filename ""} } {
    variable outputFile
    if {[llength [info level 0]] == 1} {
	return $outputFile
    }
    switch -exact -- $filename {
	stderr -
	stdout {
	    # do nothing
	}
	default {
	    MakeAbsolutePath filename [temporaryDirectory]
	}
    }
    outputChannel $filename
    set outputFile $filename
}

# tcltest::errorChannel --
#
#	set or return the error file descriptor based on the supplied
#       file name (where tcltest sends all its errors)
#
# Arguments:
#	error file name
#
# Results:
#	file descriptor corresponding to the supplied file name (or
#       currently set file descriptor, if no new filename was supplied)
#       - this is the content of tcltest::errorChannel
#
# Side effects:
#	opens the descriptor in w mode unless the filename is set to
#       stderr or stdout

proc tcltest::errorChannel { {filename ""} } {
    variable errorChannel
    if {[llength [info level 0]] == 1} {
	return $errorChannel
    }
    switch -exact -- $filename {
	stderr -
	stdout {
	    set errorChannel $filename
	}
	default {
	    set errorChannel [open $filename w]
	}
    }
    return $errorChannel
}

# tcltest::errorFile --
#
#	set or return the error file name; calls [errorChannel] to set
#       the corresponding file descriptor
#
# Arguments:
#	error file name
#
# Results:
#	content of tcltest::errorFile
#
# Side effects:
#	if the file name supplied is relative, it will be made absolute
#       with respect to the predefined temporaryDirectory

proc tcltest::errorFile { {filename ""} } {
    variable errorFile
    if {[llength [info level 0]] == 1} {
	return $errorFile
    }
    switch -exact -- $filename {
	stderr -
	stdout {
	    # do nothing
	}
	default {
	    MakeAbsolutePath filename [temporaryDirectory]
	}
    }
    set errorFile $filename
    errorChannel $errorFile
    return $errorFile
}

# tcltest::testConstraint --
#
#	sets a test constraint to a value; to do multiple constraints,
#       call this proc multiple times.  also returns the value of the
#       named constraint if no value was supplied.







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
<
<
<
<
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|

|

<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







811
812
813
814
815
816
817























818

819






820

821































































822
823






















824


























825







826


























































827
828
829
830












831


































































832
833
834
835
836
837
838
	uplevel 1 $script
    }
    return
}

#####################################################################
























proc tcltest::Warn {msg} {

    puts [outputChannel] "WARNING: $msg"






}

































































# tcltest::mainThread
#






















#     Accessor command for tcltest variable mainThread.


























#







proc tcltest::mainThread { {new ""} } {


























































    variable mainThread
    if {[llength [info level 0]] == 1} {
	return $mainThread
    }












    set mainThread $new


































































}

# tcltest::testConstraint --
#
#	sets a test constraint to a value; to do multiple constraints,
#       call this proc multiple times.  also returns the value of the
#       named constraint if no value was supplied.
673
674
675
676
677
678
679

680
681
682
683
684
685
686




687
688
689
690
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
#	content of tcltest::testConstraints($constraint)
#
# Side effects:
#	none

proc tcltest::testConstraint {constraint {value ""}} {
    variable testConstraints

    DebugPuts 3 "entering testConstraint $constraint $value"
    if {[llength [info level 0]] == 2} {
	return $testConstraints($constraint)
    }
    # Check for boolean values
    if {[catch {expr {$value && $value}} msg]} {
	return -code error $msg




    }
    set testConstraints($constraint) $value
}

# tcltest::limitConstraints --
#
#	sets/gets flag indicating whether tests run are limited only
#	to those matching constraints specified by the -constraints
#	command line option.
#
# Arguments:
#	new boolean value for the flag
#
# Results:
#	content of tcltest::limitConstraints
#
# Side effects:
#	None.

proc tcltest::limitConstraints { {value ""} } {
    variable testConstraints
    variable limitConstraints
    DebugPuts 3 "entering limitConstraints $value"
    if {[llength [info level 0]] == 1} {
	return $limitConstraints
    }
    # Check for boolean values
    if {[catch {expr {$value && $value}} msg]} {
	return -code error $msg
    }
    set limitConstraints $value
    if {!$limitConstraints} {return $limitConstraints}
    foreach elt [array names testConstraints] {
	if {[lsearch -exact [ConstraintsSpecifiedByCommandLineArgument] $elt] 
		== -1} {
	    testConstraint $elt 0
	}
    }
    return $limitConstraints
}

# tcltest::loadFile --
#
#	set the load file (containing the load script);
#       put the content of the load file into loadScript
#
# Arguments:
#	script's file name
#
# Results:
#	content of tcltest::loadFile
#
# Side effects:
#	None.

proc tcltest::loadFile { {scriptFile ""} } {
    variable loadFile
    if {[llength [info level 0]] == 1} {
	return $loadFile
    }
    MakeAbsolutePath scriptFile [temporaryDirectory]
    set tmp [open $scriptFile r]
    loadScript [read $tmp]
    close $tmp
    set loadFile $scriptFile
}

# tcltest::workingDirectory --
#
#	set workingDirectory to the given path.  If the path is
#       relative, make it absolute.  Change directory to the stated
#       working directory, if resetting the value
#
# Arguments:
#	directory name
#
# Results:
#	content of tcltest::workingDirectory
#
# Side effects:
#	None.

proc tcltest::workingDirectory { {dir ""} } {
    variable workingDirectory
    if {[llength [info level 0]] == 1} {
	return $workingDirectory
    }
    set workingDirectory $dir
    MakeAbsolutePath workingDirectory
    cd $workingDirectory
    return $workingDirectory
}

# tcltest::temporaryDirectory --
#
#     Set temporaryDirectory to the given path.  If the path is
#     relative, make it absolute.  If the file exists but is not a dir,
#     then return an error.
#
#     If temporaryDirectory does not already exist, create it.  If you
#     cannot create it, then return an error (the file mkdir isn't
#     caught and will propagate).
#
# Arguments:
#	directory name
#
# Results:
#	content of tcltest::temporaryDirectory
#
# Side effects:
#	None.

proc tcltest::temporaryDirectory { {dir ""} } {
    variable temporaryDirectory
    if {[llength [info level 0]] == 1} {
	return $temporaryDirectory
    }
    set temporaryDirectory $dir
    MakeAbsolutePath temporaryDirectory

    if {[file exists $temporaryDirectory]} {
	CheckDirectory rw $temporaryDirectory \
		{bad argument for temporary directory: }
    } else {
	file mkdir $temporaryDirectory
    }

    normalizePath temporaryDirectory
}

# tcltest::testsDirectory --
#
#     Set testsDirectory to the given path.  If the path is relative,
#     make it absolute.  If the file exists but is not a dir, then
#     return an error.
#
#     If testsDirectory does not already exist, return an error.
#
# Arguments:
#	directory name
#
# Results:
#	content of tcltest::testsDirectory
#
# Side effects:
#	None.

proc tcltest::testsDirectory { {dir ""} } {
    variable testsDirectory
    if {[llength [info level 0]] == 1} {
	return $testsDirectory
    }

    set testsDirectory $dir
    MakeAbsolutePath testsDirectory
    set testDirError "bad argument for tests directory: "
    if {[file exists $testsDirectory]} {
	CheckDirectory r $testsDirectory $testDirError
    } else {
	return -code error \
		"$testDirError \"$testsDirectory\" does not exist"
    }

    normalizePath testsDirectory
}

# tcltest::interpreter --
#
#	the interpreter name stored in tcltest::tcltest
#
# Arguments:
#	executable name
#







>







>
>
>
>




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868


































































































































































869
870
871
872
873
874
875
#	content of tcltest::testConstraints($constraint)
#
# Side effects:
#	none

proc tcltest::testConstraint {constraint {value ""}} {
    variable testConstraints
    variable Option
    DebugPuts 3 "entering testConstraint $constraint $value"
    if {[llength [info level 0]] == 2} {
	return $testConstraints($constraint)
    }
    # Check for boolean values
    if {[catch {expr {$value && $value}} msg]} {
	return -code error $msg
    }
    if {[limitConstraints] 
	    && [lsearch -exact $Option(-constraints) $constraint] == -1} {
	set value 0
    }
    set testConstraints($constraint) $value
}



































































































































































# tcltest::interpreter --
#
#	the interpreter name stored in tcltest::tcltest
#
# Arguments:
#	executable name
#
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
    ConstraintInitializer unixOrWin \
	    {expr {[testConstraint unix] || [testConstraint win]}}
    ConstraintInitializer macOrWin \
	    {expr {[testConstraint mac] || [testConstraint win]}}
    ConstraintInitializer macOrUnix \
	    {expr {[testConstraint mac] || [testConstraint unix]}}

    ConstraintInitializer nt {string equal $tcl_platform(os) "Windows NT"}
    ConstraintInitializer 95 {string equal $tcl_platform(os) "Windows 95"}
    ConstraintInitializer 98 {string equal $tcl_platform(os) "Windows 98"}

    # The following Constraints switches are used to mark tests that
    # should work, but have been temporarily disabled on certain
    # platforms because they don't and we haven't gotten around to
    # fixing the underlying problem.

    ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}







|
|
|







1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
    ConstraintInitializer unixOrWin \
	    {expr {[testConstraint unix] || [testConstraint win]}}
    ConstraintInitializer macOrWin \
	    {expr {[testConstraint mac] || [testConstraint win]}}
    ConstraintInitializer macOrUnix \
	    {expr {[testConstraint mac] || [testConstraint unix]}}

    ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
    ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
    ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}

    # The following Constraints switches are used to mark tests that
    # should work, but have been temporarily disabled on certain
    # platforms because they don't and we haven't gotten around to
    # fixing the underlying problem.

    ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327






1328





1329
1330
1331
1332

1333



1334





1335
1336

1337



1338
1339
1340
1341
1342
1343
1344




1345
1346
1347


1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
	}
	set code
    }

}
#####################################################################

# Handle command line arguments (from argv) and default arg settings
# (in TCLTEST_OPTIONS).

# tcltest::PrintUsageInfoHook
#
#       Hook used for customization of display of usage information.
#

if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} {
    proc tcltest::PrintUsageInfoHook {} {}
}

# tcltest::PrintUsageInfo
#
#	Prints out the usage information for package tcltest.  This can
#	be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
#	none
#
# Results:
#       none
#
# Side Effects:
#       none
proc tcltest::PrintUsageInfo {} {
    puts "Usage: [file tail [info nameofexecutable]]\
	script ?-help? ?flag value? ... \n\
	Available flags (and valid input values) are:\n\
	-help          		 Display this usage information.\n\
	-verbose level 		 Takes any combination of the values\n\
	\t                 'p', 's', 'b', 't' and 'e'. \
			   Test suite will\n\
	\t                 display all passed tests if 'p' is\n\
	\t                 specified, all skipped tests if 's'\n\
	\t                 is specified, the bodies of\n\
	\t                 failed tests if 'b' is specified,\n\
	\t                 and when tests start if 't' is specified.\n\
	\t                 ErrorInfo is displayed\
			   if 'e' is specified.\n\
	\t                 The default value is 'b'.\n\
	-constraints list	 Do not skip the listed constraints\n\
	-limitconstraints bool	 Only run tests with the constraints\n\
	\t                 listed in -constraints.\n\
	-match pattern 		 Run all tests within the specified\n\
	\t                 files that match the glob pattern\n\
	\t                 given.\n\
	-skip pattern  		 Skip all tests within the set of\n\
	\t                 specified tests (via -match) and\n\
	\t                 files that match the glob pattern\n\
	\t                 given.\n\
	-file pattern  		 Run tests in all test files that\n\
	\t                 match the glob pattern given.\n\
	-notfile pattern	 Skip all test files that match the\n\
	\t                 glob pattern given.\n\
	-relateddir pattern	 Run tests in directories that match\n\
	\t                 the glob pattern given.\n\
	-asidefromdir pattern	 Skip tests in directories that match\n\
	\t                 the glob pattern given.\n\
	-preservecore level 	 If 2, save any core files produced\n\
	\t                 during testing in the directory\n\
	\t                 specified by -tmpdir. If 1, notify the\n\
	\t                 user if core files are created. \
			   The default\n\
	\t                 is [preserveCore].\n\
	-tmpdir directory	 Save temporary files\
			   in the specified\n\
	\t                 directory.  The default value is\n\
	\t                 [temporaryDirectory]\n\
	-testdir directories	 Search tests in the specified\n\
	\t                 directories.  The default value is\n\
	\t                 [testsDirectory].\n\
	-outfile file    	 Send output from test runs to the\n\
	\t                 specified file.  The default is\n\
	\t                 stdout.\n\
	-errfile file    	 Send errors from test runs to the\n\
	\t                 specified file.  The default is\n\
	\t                 stderr.\n\
	-loadfile file   	 Read the script to load the tested\n\
	\t                 commands from the specified file.\n\
	-load script     	 Specifies the script\
			   to load the tested\n\
	\t                 commands.\n\
	-debug level     	 Internal debug flag."
    PrintUsageInfoHook
    return
}

# tcltest::processCmdLineArgsFlagsHook --






#





#	This hook is used to add to the list of command line arguments
#	that are processed by tcltest::ProcessFlags.   It is called at
#	the beginning of ProcessFlags.
#





if {[llength [info commands \





	tcltest::processCmdLineArgsAddFlagsHook]] == 0} {
    proc tcltest::processCmdLineArgsAddFlagsHook {} {}

}




# tcltest::processCmdLineArgsHook --
#
#	This hook is used to actually process the flags added by
#       tcltest::processCmdLineArgsAddFlagsHook.  It is called at the
#	end of ProcessFlags.
#




# Arguments:
#	flags      The flags that have been pulled out of argv
#



if {[llength [info commands tcltest::processCmdLineArgsHook]] == 0} {
    proc tcltest::processCmdLineArgsHook {flag} {}
}

# tcltest::ProcessFlags --
#
#	process command line arguments supplied in the flagArray - this
#	is called by processCmdLineArgs.  Modifies tcltest variables
#	according to the content of the flagArray.







|
<
<
<
<
<
<
<
<
<
<















|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

<


|
>
>
>
>
>
>
|
>
>
>
>
>
|
<
|
<
>
|
>
>
>
|
>
>
>
>
>
|
<
>
|
>
>
>
|
<
<
<
<
|
<
>
>
>
>
|
<
<
>
>
|
<
<







1248
1249
1250
1251
1252
1253
1254
1255










1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271

























































1272

1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288

1289

1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301

1302
1303
1304
1305
1306
1307




1308

1309
1310
1311
1312
1313


1314
1315
1316


1317
1318
1319
1320
1321
1322
1323
	}
	set code
    }

}
#####################################################################

# Usage and command line arguments processing.











# tcltest::PrintUsageInfo
#
#	Prints out the usage information for package tcltest.  This can
#	be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
#	none
#
# Results:
#       none
#
# Side Effects:
#       none
proc tcltest::PrintUsageInfo {} {
    puts [Usage]

























































    PrintUsageInfoHook

}

proc tcltest::Usage { {option ""} } {
    variable Usage
    variable Verify
    if {[llength [info level 0]] == 1} {
	set msg "Usage: [file tail [info nameofexecutable]] script "
	append msg "?-help? ?flag value? ... \n"
	append msg "Available flags (and valid input values) are:"

	set max 0
	set allOpts [concat -help [Configure]]
	foreach opt $allOpts {
	    set foo [Usage $opt]
	    foreach [list x type($opt) usage($opt)] $foo break
	    set line($opt) "  $opt $type($opt)  "

	    set length($opt) [string length $line($opt)]

	    if {$length($opt) > $max} {set max $length($opt)}
	}
	set rest [expr {72 - $max}]
	foreach opt $allOpts {
	    append msg \n$line($opt)
	    append msg [string repeat " " [expr {$max - $length($opt)}]]
	    set u [string trim $usage($opt)]
	    catch {append u "  (default: \[[Configure $opt]])"}
	    regsub -all {\s*\n\s*} $u " " u
	    while {[string length $u] > $rest} {
		set break [string wordstart $u $rest]
		if {$break == 0} {

		    set break [string wordend $u 0]
		}
		append msg [string range $u 0 [expr {$break - 1}]]
		set u [string trim [string range $u $break end]]
		append msg \n[string repeat " " $max]
	    }




	    append msg $u

	}
	return $msg\n
    } elseif {[string equal -help $option]} {
	return [list -help "" "Display this usage information."]
    } else {


	set type [lindex [info args $Verify($option)] 0]
	return [list $option $type $Usage($option)]
    }


}

# tcltest::ProcessFlags --
#
#	process command line arguments supplied in the flagArray - this
#	is called by processCmdLineArgs.  Modifies tcltest variables
#	according to the content of the flagArray.
1369
1370
1371
1372
1373
1374
1375
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
proc tcltest::ProcessFlags {flagArray} {
    # Process -help first
    if {[lsearch -exact $flagArray {-help}] != -1} {
	PrintUsageInfo
	exit 1
    }

    catch {array set flag $flagArray}

    # -help is not listed since it has already been processed
    lappend defaultFlags -verbose -match -skip -constraints \
	    -outfile -errfile -debug -tmpdir -file -notfile \
	    -preservecore -limitconstraints -testdir \
	    -load -loadfile -asidefromdir \
	    -relateddir -singleproc
    set defaultFlags \
	    [concat $defaultFlags [processCmdLineArgsAddFlagsHook]]

    # Set verbose to the arg of the -verbose flag, if given
    if {[info exists flag(-verbose)]} {
	verbose $flag(-verbose)
    }

    # Set match to the arg of the -match flag, if given.

    if {[info exists flag(-match)]} {
	match $flag(-match)
    }

    # Set skip to the arg of the -skip flag, if given

    if {[info exists flag(-skip)]} {

	skip $flag(-skip)
    }

    # Handle the -file and -notfile flags
    if {[info exists flag(-file)]} {
	matchFiles $flag(-file)


    }
    if {[info exists flag(-notfile)]} {
	skipFiles $flag(-notfile)
    }

    # Handle -relateddir and -asidefromdir flags
    if {[info exists flag(-relateddir)]} {
	matchDirectories $flag(-relateddir)
    }
    if {[info exists flag(-asidefromdir)]} {
	skipDirectories $flag(-asidefromdir)
    }

    # Use the -constraints flag, if given, to turn on constraints that
    # are turned off by default: userInteractive knownBug nonPortable.

    if {[info exists flag(-constraints)]} {
	foreach elt $flag(-constraints) {
	    testConstraint $elt 1
	}
	ConstraintsSpecifiedByCommandLineArgument $flag(-constraints)
    }

    # Use the -limitconstraints flag, if given, to tell the harness to
    # limit tests run to those that were specified using the
    # -constraints flag.  If the -constraints flag was not specified,
    # print out an error and exit.
    if {[info exists flag(-limitconstraints)]} {
	if {![info exists flag(-constraints)]} {
	    error "-limitconstraints flag can only\
		    be used with -constraints"
	}
	limitConstraints $flag(-limitconstraints)
    }

    # Set the temporaryDirectory to the arg of -tmpdir, if given.

    if {[info exists flag(-tmpdir)]} {
	temporaryDirectory $flag(-tmpdir)
    }

    # Set the testsDirectory to the arg of -testdir, if given.

    if {[info exists flag(-testdir)]} {
	testsDirectory $flag(-testdir)
    }

    # If an alternate error or output files are specified, change the
    # default channels.

    if {[info exists flag(-outfile)]} {
	outputFile $flag(-outfile)
    }

    if {[info exists flag(-errfile)]} {
	errorFile $flag(-errfile)
    }

    # If a load script was specified, either directly or through
    # a file, remember it for later usage.

    if {[info exists flag(-load)] &&  \
	    ([lsearch -exact $flagArray -load] > \
		[lsearch -exact $flagArray -loadfile])} {
	loadScript $flag(-load)
    }

    if {[info exists flag(-loadfile)] && \
	    ([lsearch -exact $flagArray -loadfile] > \
		[lsearch -exact $flagArray -load]) } {
	loadFile $flag(-loadfile)
    }

    # If the user specifies debug testing, print out extra information
    # during the run.
    if {[info exists flag(-debug)]} {
	debug $flag(-debug)
    }

    # Handle -preservecore
    if {[info exists flag(-preservecore)]} {
	preserveCore $flag(-preservecore)
    }

    # Handle -singleproc flag
    if {[info exists flag(-singleproc)]} {
	singleProcess $flag(-singleproc)
    }

    # Call the hook

    processCmdLineArgsHook [array get flag]
    return
}

# tcltest::ProcessCmdLineArgs --
#
#	Use command line args to set tcltest namespace variables.
#
#       This procedure must be run after constraints are initialized,

#	because some constraints can be overridden.
#
#       Set variables based on the contents of the environment variable
#       TCLTEST_OPTIONS first, then override with command-line options,
#	if specified.
#
# Arguments:
#	none
#
# Results:
#	Sets the above-named variables in the tcltest namespace.
#
# Side Effects:
#       None.
#

proc tcltest::ProcessCmdLineArgs {} {
    global argv
    variable originalEnv
    variable testConstraints

    # If the TCLTEST_OPTIONS environment variable exists, parse it
    # first, then the argv list.  The command line argument parsing will
    # be a two-pass affair from now on, so that TCLTEST_OPTIONS contain
    # the default options.  These can be overridden by the command line
    # flags.

    if {[info exists ::env(TCLTEST_OPTIONS)]} {
	ProcessFlags $::env(TCLTEST_OPTIONS)
    }

    # The "argv" var doesn't exist in some cases, so use {}.
    if {(![info exists argv]) || ([llength $argv] < 1)} {
	set flagArray {}
    } else {
	set flagArray $argv
    }

    ProcessFlags $flagArray

    # Spit out everything you know if we're at a debug level 2 or
    # greater
    DebugPuts 2 "Flags passed into tcltest:"
    if {[info exists ::env(TCLTEST_OPTIONS)]} {
	DebugPuts 2 \
		"    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
    }
    if {[info exists argv]} {
	DebugPuts 2 "    argv: $argv"
    }
    DebugPuts    2 "tcltest::debug              = [debug]"
    DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
    DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
    DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
    DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
    DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
    DebugPuts    2 "Original environment (tcltest::originalEnv):"
    DebugPArray  2 originalEnv
    DebugPuts    2 "Constraints:"
    DebugPArray  2 testConstraints
    return
}

#####################################################################

# Code to run the tests goes here.

# tcltest::TestPuts --







|
|
<
<
<
<
<
|
|
<
|
<
<
<
|
|
<
>
|
<
<
|
<
>
|
>
|
<
|
|
<
<
>
>
|
<
<
<
|
<
<
<
|
<
<
|
|
<
<
|
|
<
|
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
<
|
<
<
<
|
<
|
<
<
|
|
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



>






<
<
|
>
|

<
|
<












<



<
<
<
<
<
<
<
<
<
<

|
|

|


<
<




















<







1335
1336
1337
1338
1339
1340
1341
1342
1343





1344
1345

1346



1347
1348

1349
1350


1351

1352
1353
1354
1355

1356
1357


1358
1359
1360



1361



1362


1363
1364


1365
1366

1367
1368











1369


1370

1371



1372

1373


1374
1375


1376





































1377
1378
1379
1380
1381
1382
1383
1384
1385
1386


1387
1388
1389
1390

1391

1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403

1404
1405
1406










1407
1408
1409
1410
1411
1412
1413


1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433

1434
1435
1436
1437
1438
1439
1440
proc tcltest::ProcessFlags {flagArray} {
    # Process -help first
    if {[lsearch -exact $flagArray {-help}] != -1} {
	PrintUsageInfo
	exit 1
    }

    if {[llength $flagArray] == 0} {
	RemoveAutoConfigureTraces





    } else {
	set args $flagArray

	while {[llength $args] && [catch {eval configure $args} msg]} {




	    # Something went wrong parsing $args for tcltest options

	    # Check whether the problem is "unknown option"
	    if {[regexp {^unknown option (\S+):} $msg -> option]} {


		# Could be this is an option the Hook knows about

		set moreOptions [processCmdLineArgsAddFlagsHook]
		if {[lsearch -exact $moreOptions $option] == -1} {
		    # Nope.  Report the error, including additional options,
		    # but keep going

		    if {[llength $moreOptions]} {
			append msg ", "


			append msg [join [lrange $moreOptions 0 end -1] ", "]
			append msg "or [lindex $moreOptions end]"
		    }



		    Warn $msg



		}


	    } else {
		# error is something other than "unknown option"


		# notify user of the error; and exit
		puts [errorChannel] $msg

		exit 1
	    }














	    # To recover, find that unknown option and remove up to it.

	    # then retry



	    while {![string equal [lindex $args 0] $option]} {

		set args [lrange $args 2 end]


	    }
	    set args [lrange $args 2 end]


	}





































    }

    # Call the hook
    array set flag $flagArray
    processCmdLineArgsHook [array get flag]
    return
}

# tcltest::ProcessCmdLineArgs --
#


#       This procedure must be run after constraint initialization is
#	set up (by [DefineConstraintInitializers]) because some constraints
#	can be overridden.
#

#       Perform configuration according to the command-line options.

#
# Arguments:
#	none
#
# Results:
#	Sets the above-named variables in the tcltest namespace.
#
# Side Effects:
#       None.
#

proc tcltest::ProcessCmdLineArgs {} {

    variable originalEnv
    variable testConstraints











    # The "argv" var doesn't exist in some cases, so use {}.
    if {![info exists ::argv]} {
	ProcessFlags {}
    } else {
	ProcessFlags $::argv
    }



    # Spit out everything you know if we're at a debug level 2 or
    # greater
    DebugPuts 2 "Flags passed into tcltest:"
    if {[info exists ::env(TCLTEST_OPTIONS)]} {
	DebugPuts 2 \
		"    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
    }
    if {[info exists argv]} {
	DebugPuts 2 "    argv: $argv"
    }
    DebugPuts    2 "tcltest::debug              = [debug]"
    DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
    DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
    DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
    DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
    DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
    DebugPuts    2 "Original environment (tcltest::originalEnv):"
    DebugPArray  2 originalEnv
    DebugPuts    2 "Constraints:"
    DebugPArray  2 testConstraints

}

#####################################################################

# Code to run the tests goes here.

# tcltest::TestPuts --
1616
1617
1618
1619
1620
1621
1622

1623
1624
1625
1626
1627
1628

1629
1630
1631
1632
1633
1634
1635
	}
    }

    if {[info exists channel]} {
	if {[string equal $channel [[namespace parent]::outputChannel]]
		|| [string equal $channel stdout]} {
	    append outData [lindex $args end]\n

	} elseif {[string equal $channel [[namespace parent]::errorChannel]]
		|| [string equal $channel stderr]} {
	    append errData [lindex $args end]\n
	}
	return
	# return [Puts [lindex $args 0] [lindex $args end]]

    }

    # If we haven't returned by now, we don't know how to handle the
    # input.  Let puts handle it.
    return [eval Puts $args]
}








>



<
|
<
>







1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495

1496

1497
1498
1499
1500
1501
1502
1503
1504
	}
    }

    if {[info exists channel]} {
	if {[string equal $channel [[namespace parent]::outputChannel]]
		|| [string equal $channel stdout]} {
	    append outData [lindex $args end]\n
	    return
	} elseif {[string equal $channel [[namespace parent]::errorChannel]]
		|| [string equal $channel stderr]} {
	    append errData [lindex $args end]\n

	    return

	}
    }

    # If we haven't returned by now, we don't know how to handle the
    # input.  Let puts handle it.
    return [eval Puts $args]
}

1889
1890
1891
1892
1893
1894
1895

1896
1897

1898
1899
1900
1901
1902
1903
1904
# Side effects:
#       Just about anything is possible depending on the test.
#

proc tcltest::test {name description args} {
    global tcl_platform
    variable testLevel

    DebugPuts 3 "test $name $args"


    incr testLevel

    # Pre-define everything to null except output and errorOutput.  We
    # determine whether or not to trap output based on whether or not
    # these variables (output & errorOutput) are defined.
    foreach item {constraints setup cleanup body result returnCodes
	    match} {







>


>







1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
# Side effects:
#       Just about anything is possible depending on the test.
#

proc tcltest::test {name description args} {
    global tcl_platform
    variable testLevel
    variable coreModTime
    DebugPuts 3 "test $name $args"

    FillFilesExisted
    incr testLevel

    # Pre-define everything to null except output and errorOutput.  We
    # determine whether or not to trap output based on whether or not
    # these variables (output & errorOutput) are defined.
    foreach item {constraints setup cleanup body result returnCodes
	    match} {
1920
1921
1922
1923
1924
1925
1926
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
	if {[llength $args] == 1} {
	    set list [SubstArguments [lindex $args 0]]
	    foreach {element value} $list {
		set testAttributes($element) $value
	    }
	    foreach item {constraints match setup body cleanup \
		    result returnCodes output errorOutput} {
		if {[info exists testAttributes([subst -$item])]} {
		    set testAttributes([subst -$item]) [uplevel 1 \
			    ::concat $testAttributes([subst -$item])]
		}
	    }
	} else {
	    array set testAttributes $args
	}

	set validFlags {-setup -cleanup -body -result -returnCodes \
		-match -output -errorOutput -constraints}

	foreach flag [array names testAttributes] {
	    if {[lsearch -exact $validFlags $flag] == -1} {
		incr tcltest::testLevel -1
		set sorted [lsort $validFlags]
		set options [join [lrange $sorted 0 end-1] ", "]
		append options ", or [lindex $sorted end]"
		return -code error "bad option \"$flag\": must be $options"
	    }
	}

	# store whatever the user gave us
	foreach item [array names testAttributes] {
	    set [string trimleft $item "-"] $testAttributes($item)
	}

	# Check the values supplied for -match
	variable CustomMatch
	if {[lsearch [array names CustomMatch] $match] == -1} {
	    incr tcltest::testLevel -1
	    set sorted [lsort [array names CustomMatch]]
	    set values [join [lrange $sorted 0 end-1] ", "]
	    append values ", or [lindex $sorted end]"
	    return -code error "bad -match value \"$match\":\
		    must be $values"
	}








|
|
|











|















|







1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
	if {[llength $args] == 1} {
	    set list [SubstArguments [lindex $args 0]]
	    foreach {element value} $list {
		set testAttributes($element) $value
	    }
	    foreach item {constraints match setup body cleanup \
		    result returnCodes output errorOutput} {
		if {[info exists testAttributes(-$item)]} {
		    set testAttributes(-$item) [uplevel 1 \
			    ::concat $testAttributes(-$item)]
		}
	    }
	} else {
	    array set testAttributes $args
	}

	set validFlags {-setup -cleanup -body -result -returnCodes \
		-match -output -errorOutput -constraints}

	foreach flag [array names testAttributes] {
	    if {[lsearch -exact $validFlags $flag] == -1} {
		incr testLevel -1
		set sorted [lsort $validFlags]
		set options [join [lrange $sorted 0 end-1] ", "]
		append options ", or [lindex $sorted end]"
		return -code error "bad option \"$flag\": must be $options"
	    }
	}

	# store whatever the user gave us
	foreach item [array names testAttributes] {
	    set [string trimleft $item "-"] $testAttributes($item)
	}

	# Check the values supplied for -match
	variable CustomMatch
	if {[lsearch [array names CustomMatch] $match] == -1} {
	    incr testLevel -1
	    set sorted [lsort [array names CustomMatch]]
	    set values [join [lrange $sorted 0 end-1] ", "]
	    append values ", or [lindex $sorted end]"
	    return -code error "bad -match value \"$match\":\
		    must be $values"
	}

1974
1975
1976
1977
1978
1979
1980
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
	set result [lindex $args end]
	if {[llength $args] == 2} {
	    set body [lindex $args 0]
	} elseif {[llength $args] == 3} {
	    set constraints [lindex $args 0]
	    set body [lindex $args 1]
	} else {
	    incr tcltest::testLevel -1
	    return -code error "wrong # args:\
		    should be \"test name desc ?options?\""
	}
    }



    set setupFailure 0

    set cleanupFailure 0







    # Run the setup script
    if {[catch {uplevel 1 $setup} setupMsg]} {
	set setupFailure 1
    }








    # run the test script
    set command [list [namespace origin RunTest] $name $description \
	    $body $result $constraints]
    if {!$setupFailure} {
	if {[info exists output] || [info exists errorOutput]} {
	    set testResult [uplevel 1 \
		    [list [namespace origin Eval] $command 0]]
	} else {
	    set testResult [uplevel 1 \
		    [list [namespace origin Eval] $command 1]]
	}
    } else {
	set testResult setupFailure
    }

    # Run the cleanup code
    if {[catch {uplevel 1 $cleanup} cleanupMsg]} {
	set cleanupFailure 1
    }

    # If testResult is an empty list, then the test was skipped
    if {$testResult != {}} {
	set coreFailure 0
	set coreMsg ""
	# check for a core file first - if one was created by the test,
	# then the test failed
	if {[preserveCore]} {
	    set currentTclPlatform [array get tcl_platform]
	    if {[file exists [file join [workingDirectory] core]]} {
		# There's only a test failure if there is a core file
		# and (1) there previously wasn't one or (2) the new
		# one is different from the old one.
		variable coreModTime
		if {[info exists coreModTime]} {
		    if {$coreModTime != [file mtime \
			    [file join [workingDirectory] core]]} {
			set coreFailure 1
		    }
		} else {
		    set coreFailure 1
		}
		
		if {([preserveCore] > 1) && ($coreFailure)} {
		    append coreMsg "\nMoving file to:\
			    [file join [temporaryDirectory] core-$name]"
		    catch {file rename -force \
			    [file join [workingDirectory] core] \
			    [file join [temporaryDirectory] core-$name]
		    } msg
		    if {[string length $msg] > 0} {
			append coreMsg "\nError:\
				Problem renaming core file: $msg"
		    }
		}
	    }
	    array set tcl_platform $currentTclPlatform
	}

	set actualAnswer [lindex $testResult 0]
	set code [lindex $testResult end]

	# If expected output/error strings exist, we have to compare
	# them.  If the comparison fails, then so did the test.
	set outputFailure 0
	variable outData
	if {[info exists output]} {
	    if {[set outputCompare [catch {
		CompareStrings $outData $output $match
	    } outputMatch]] == 0} {
		set outputFailure [expr {!$outputMatch}]
	    } else {
		set outputFailure 1
	    }
	}

	set errorFailure 0
	variable errData
	if {[info exists errorOutput]} {
	    if {[set errorCompare [catch {
		CompareStrings $errData $errorOutput $match
	    } errorMatch]] == 0} {
		set errorFailure [expr {!$errorMatch}]
	    } else {
		set errorFailure 1
	    }
	}

	# check if the return code matched the expected return code
	set codeFailure 0
	if {[lsearch -exact $returnCodes $code] == -1} {
	    set codeFailure 1
	}

	# check if the answer matched the expected answer



	if {[set scriptCompare [catch {
	    CompareStrings $actualAnswer $result $match
	} scriptMatch]] == 0} {
	    set scriptFailure [expr {!$scriptMatch}]
	} else {
	    set scriptFailure 1
	}

	# if we didn't experience any failures, then we passed
	set testFailed 1
	variable numTests
	if {!($setupFailure || $cleanupFailure || $coreFailure
		|| $outputFailure || $errorFailure || $codeFailure
		|| $scriptFailure)} {
	    if {$testLevel == 1} {
		incr numTests(Passed)
		if {[IsVerbose pass]} {
		    puts [outputChannel] "++++ $name PASSED"
		}
	    }
	    set testFailed 0

	}

	if {$testFailed} {
	    if {$testLevel == 1} {
		incr numTests(Failed)
	    }


	    variable currentFailure true
	    if {![IsVerbose body]} {
		set body ""
	    }	
	    puts [outputChannel] "\n==== $name\
		    [string trim $description] FAILED"
	    if {[string length $body]} {
		puts [outputChannel] "==== Contents of test case:"
		puts [outputChannel] $body
	    }
	    if {$setupFailure} {
		puts [outputChannel] "---- Test setup\
			failed:\n$setupMsg"
	    }
	    if {$scriptFailure} {
	      if {$scriptCompare} {
		puts [outputChannel] "---- Error testing result: $scriptMatch"
	      } else {
		puts [outputChannel] "---- Result\
			was:\n$actualAnswer"
		puts [outputChannel] "---- Result should have been\
			($match matching):\n$result"
	      }
	    }
	    if {$codeFailure} {
		switch -- $code {
		    0 { set msg "Test completed normally" }
		    1 { set msg "Test generated error" }
		    2 { set msg "Test generated return exception" }
		    3 { set msg "Test generated break exception" }
		    4 { set msg "Test generated continue exception" }
		    default { set msg "Test generated exception" }
		}
		puts [outputChannel] "---- $msg; Return code was: $code"
		puts [outputChannel] "---- Return code should have been\
			one of: $returnCodes"
		if {[IsVerbose error]} {
		    if {[info exists ::errorInfo]} {
			puts [outputChannel] "---- errorInfo:\
				$::errorInfo"
			puts [outputChannel] "---- errorCode:\
				$::errorCode"
		    }
		}
	    }
	    if {$outputFailure} {
	      if {$outputCompare} {
		puts [outputChannel] "---- Error testing output: $outputMatch"
	      } else {
		puts [outputChannel] "---- Output was:\n$outData"
		puts [outputChannel] "---- Output should have been\
			($match matching):\n$output"
	      }
	    }
	    if {$errorFailure} {
	      if {$errorCompare} {
		puts [outputChannel] "---- Error testing errorOutput:\
			$errorMatch"
	      } else {
		puts [outputChannel] "---- Error output was:\n$errData"
		puts [outputChannel] "---- Error output should have\
			been ($match matching):\n$errorOutput"
	      }
	    }
	    if {$cleanupFailure} {
		puts [outputChannel] "---- Test cleanup\
			failed:\n$cleanupMsg"
	    }
	    if {$coreFailure} {
		puts [outputChannel] "---- Core file produced while\
			running test!  $coreMsg"
	    }
	    puts [outputChannel] "==== $name FAILED\n"

	}
    }

    incr testLevel -1
    return
}


# RunTest --
#
# This is the defnition of the version 1.0 test routine for tcltest.  It
# is provided here for backward compatibility.  It is also used as the
# 'backbone' of the test procedure, as in, this is where all the work
# really gets done.  This procedure runs a test and prints an error
# message if the test fails.  If verbose has been set, it also prints a
# message even if the test succeeds.  The test will be skipped if it
# doesn't match the match variable, if it matches an element in skip, or
# if one of the elements of "constraints" turns out not to be true.
#
# Arguments:
# name -		Name of test, in the form foo-1.2.
# description -		Short textual description of the test, to help
#			humans understand what it does.
# constraints -		A list of one or more keywords, each of which
#			must be the name of an element in the array
#			"testConstraints".  If any of these elements is
#			zero, the test is skipped.  This argument may be
#			omitted.
# script -		Script to run to carry out the test.  It must
#			return a result that can be checked for
#			correctness.
# expectedAnswer -	Expected result from script.
#
# Behavior depends on the value of testLevel; if testLevel is 1 (top
# level), then events are logged and we track the number of tests
# run/skipped and why.  Otherwise, we don't track this information.
#
# Results:
#    empty list if test is skipped; otherwise returns list containing
#    actual returned value from the test and the return code.
#
# Side Effects:
#    none.
#

proc tcltest::RunTest {
	name description script expectedAnswer constraints
} {
    variable testLevel
    variable numTests
    variable skip
    variable match
    variable testConstraints
    variable originalTclPlatform
    variable coreModTime

    if {$testLevel == 1} {
	incr numTests(Total)
    }

    # skip the test if it's name matches an element of skip
    foreach pattern $skip {
	if {[string match $pattern $name]} {
	    if {$testLevel == 1} {
		incr numTests(Skipped)
		DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
	    }
	    return
	}
    }

    # skip the test if it's name doesn't match any element of match
    if {[llength $match] > 0} {
	set ok 0
	foreach pattern $match {
	    if {[string match $pattern $name]} {
		set ok 1
		break
	    }
        }
	if {!$ok} {
	    if {$testLevel == 1} {
		incr numTests(Skipped)
		DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
	    }
	    return
	}
    }

    DebugPuts 3 "Running $name ($description) {$script}\
	    {$expectedAnswer} $constraints"

    if {[string equal {} $constraints]} {
	# If we're limited to the listed constraints and there aren't
	# any listed, then we shouldn't run the test.
	if {[limitConstraints]} {
	    AddToSkippedBecause userSpecifiedLimitConstraint
	    if {$testLevel == 1} {
		incr numTests(Skipped)
	    }
	    return
	}
    } else {
	# "constraints" argument exists;
	# make sure that the constraints are satisfied.

	set doTest 0
	if {[string match {*[$\[]*} $constraints] != 0} {







|





>
>
|
>
|
>
>
>
>
|
>
>
|
|
|
|
>
>

>
>
>
>
>
|
|
<
<

|
<

|
<

<
|


|
|
|
|
<
<
<
|
|
|
|
|
<
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|

<
<
<
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|

|
>
>
>
|
|
|
|
|
|
|

|
<
|
|
|
|
|
|
|
|
|
|
|
>
|

|
|
|
|
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
<
|
|
|
|
|
|
<
<
<





|
<

<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
|
<
<
<
<
<

<
<
<
<
<
<
<
<
|
<

<
|
<
<


<
<

<
<




<

|





|


<

<
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<








|







1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883


1884
1885

1886
1887

1888

1889
1890
1891
1892
1893
1894
1895



1896
1897
1898
1899
1900

1901
1902
1903
1904

1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926

1927
1928



1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973

1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012

2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031

2032

2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047

2048
2049
2050
2051
2052
2053
2054
2055

2056
2057
2058
2059
2060
2061



2062
2063
2064
2065
2066
2067

2068













2069


2070





2071








2072

2073

2074


2075
2076


2077


2078
2079
2080
2081

2082
2083
2084
2085
2086
2087
2088
2089
2090
2091

2092

2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106





2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
	set result [lindex $args end]
	if {[llength $args] == 2} {
	    set body [lindex $args 0]
	} elseif {[llength $args] == 3} {
	    set constraints [lindex $args 0]
	    set body [lindex $args 1]
	} else {
	    incr testLevel -1
	    return -code error "wrong # args:\
		    should be \"test name desc ?options?\""
	}
    }

    if {[Skipped $name $constraints]} {
	incr testLevel -1
	return
    }

    # Save information about the core file.  
    if {[preserveCore]} {
	if {[file exists [file join [workingDirectory] core]]} {
	    set coreModTime [file mtime [file join [workingDirectory] core]]
	}
    }

    # First, run the setup script
    set code [catch {uplevel 1 $setup} setupMsg]
    set setupFailure [expr {$code != 0}]

    # Only run the test body if the setup was successful
    if {!$setupFailure} {

	# Verbose notification of $body start
	if {[IsVerbose start]} {
	    puts [outputChannel] "---- $name start"
	    flush [outputChannel]
	}

	set command [list [namespace origin RunTest] $name $body]


	if {[info exists output] || [info exists errorOutput]} {
	    set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]

	} else {
	    set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]

	}

	foreach {actualAnswer returnCode} $testResult break
    }

    # Always run the cleanup script
    set code [catch {uplevel 1 $cleanup} cleanupMsg]
    set cleanupFailure [expr {$code != 0}]




    set coreFailure 0
    set coreMsg ""
    # check for a core file first - if one was created by the test,
    # then the test failed
    if {[preserveCore]} {

	if {[file exists [file join [workingDirectory] core]]} {
	    # There's only a test failure if there is a core file
	    # and (1) there previously wasn't one or (2) the new
	    # one is different from the old one.

	    if {[info exists coreModTime]} {
		if {$coreModTime != [file mtime \
			[file join [workingDirectory] core]]} {
		    set coreFailure 1
		}
	    } else {
		set coreFailure 1
	    }
	
	    if {([preserveCore] > 1) && ($coreFailure)} {
		append coreMsg "\nMoving file to:\
		    [file join [temporaryDirectory] core-$name]"
		catch {file rename -force \
		    [file join [workingDirectory] core] \
		    [file join [temporaryDirectory] core-$name]
		} msg
		if {[string length $msg] > 0} {
		    append coreMsg "\nError:\
			Problem renaming core file: $msg"
		}
	    }
	}

    }




    # If expected output/error strings exist, we have to compare
    # them.  If the comparison fails, then so did the test.
    set outputFailure 0
    variable outData
    if {[info exists output]} {
	if {[set outputCompare [catch {
	    CompareStrings $outData $output $match
	} outputMatch]] == 0} {
	    set outputFailure [expr {!$outputMatch}]
	} else {
	    set outputFailure 1
	}
    }

    set errorFailure 0
    variable errData
    if {[info exists errorOutput]} {
	if {[set errorCompare [catch {
	    CompareStrings $errData $errorOutput $match
	} errorMatch]] == 0} {
	    set errorFailure [expr {!$errorMatch}]
	} else {
	    set errorFailure 1
	}
    }

    # check if the return code matched the expected return code
    set codeFailure 0
    if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
	set codeFailure 1
    }

    # check if the answer matched the expected answer
    # Only check if we ran the body of the test (no setup failure)
    if {$setupFailure} {
	set scriptFailure 0
    } elseif {[set scriptCompare [catch {
	CompareStrings $actualAnswer $result $match
    } scriptMatch]] == 0} {
	set scriptFailure [expr {!$scriptMatch}]
    } else {
	set scriptFailure 1
    }

    # if we didn't experience any failures, then we passed

    variable numTests
    if {!($setupFailure || $cleanupFailure || $coreFailure
	    || $outputFailure || $errorFailure || $codeFailure
	    || $scriptFailure)} {
	if {$testLevel == 1} {
	    incr numTests(Passed)
	    if {[IsVerbose pass]} {
		puts [outputChannel] "++++ $name PASSED"
	    }
	}
	incr testLevel -1
	return
    }

    # We know the test failed, tally it...
    if {$testLevel == 1} {
	incr numTests(Failed)
    }

    # ... then report according to the type of failure
    variable currentFailure true
    if {![IsVerbose body]} {
	set body ""
    }	
    puts [outputChannel] "\n==== $name\
	    [string trim $description] FAILED"
    if {[string length $body]} {
	puts [outputChannel] "==== Contents of test case:"
	puts [outputChannel] $body
    }
    if {$setupFailure} {
	puts [outputChannel] "---- Test setup\
		failed:\n$setupMsg"
    }
    if {$scriptFailure} {
	if {$scriptCompare} {
	    puts [outputChannel] "---- Error testing result: $scriptMatch"
	} else {
	    puts [outputChannel] "---- Result was:\n$actualAnswer"

	    puts [outputChannel] "---- Result should have been\
		    ($match matching):\n$result"
	}
    }
    if {$codeFailure} {
	switch -- $code {
	    0 { set msg "Test completed normally" }
	    1 { set msg "Test generated error" }
	    2 { set msg "Test generated return exception" }
	    3 { set msg "Test generated break exception" }
	    4 { set msg "Test generated continue exception" }
	    default { set msg "Test generated exception" }
	}
	puts [outputChannel] "---- $msg; Return code was: $code"
	puts [outputChannel] "---- Return code should have been\
		one of: $returnCodes"
	if {[IsVerbose error]} {
	    if {[info exists ::errorInfo]} {
		puts [outputChannel] "---- errorInfo: $::errorInfo"

		puts [outputChannel] "---- errorCode: $::errorCode"

	    }
	}
    }
    if {$outputFailure} {
	if {$outputCompare} {
	    puts [outputChannel] "---- Error testing output: $outputMatch"
	} else {
	    puts [outputChannel] "---- Output was:\n$outData"
	    puts [outputChannel] "---- Output should have been\
		    ($match matching):\n$output"
	}
    }
    if {$errorFailure} {
	if {$errorCompare} {
	    puts [outputChannel] "---- Error testing errorOutput: $errorMatch"

	} else {
	    puts [outputChannel] "---- Error output was:\n$errData"
	    puts [outputChannel] "---- Error output should have\
		    been ($match matching):\n$errorOutput"
	}
    }
    if {$cleanupFailure} {
	puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"

    }
    if {$coreFailure} {
	puts [outputChannel] "---- Core file produced while running\
		test!  $coreMsg"
    }
    puts [outputChannel] "==== $name FAILED\n"




    incr testLevel -1
    return
}

# Skipped --

#













# Given a test name and it constraints, returns a boolean indicating


# whether the current configuration says the test should be skipped.





#








# Side Effects:  Maintains tally of total tests seen and tests skipped.

#

proc tcltest::Skipped {name constraints} {


    variable testLevel
    variable numTests


    variable testConstraints



    if {$testLevel == 1} {
	incr numTests(Total)
    }

    # skip the test if it's name matches an element of skip
    foreach pattern [skip] {
	if {[string match $pattern $name]} {
	    if {$testLevel == 1} {
		incr numTests(Skipped)
		DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
	    }
	    return 1
	}
    }

    # skip the test if it's name doesn't match any element of match

    set ok 0
    foreach pattern [match] {
	if {[string match $pattern $name]} {
	    set ok 1
	    break
	}
    }
    if {!$ok} {
	if {$testLevel == 1} {
	    incr numTests(Skipped)
	    DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
	}
	return 1
    }





    if {[string equal {} $constraints]} {
	# If we're limited to the listed constraints and there aren't
	# any listed, then we shouldn't run the test.
	if {[limitConstraints]} {
	    AddToSkippedBecause userSpecifiedLimitConstraint
	    if {$testLevel == 1} {
		incr numTests(Skipped)
	    }
	    return 1
	}
    } else {
	# "constraints" argument exists;
	# make sure that the constraints are satisfied.

	set doTest 0
	if {[string match {*[$\[]*} $constraints] != 0} {
2322
2323
2324
2325
2326
2327
2328
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
		puts [outputChannel] "++++ $name SKIPPED: $constraints"
	    }

	    if {$testLevel == 1} {
		incr numTests(Skipped)
		AddToSkippedBecause $constraints
	    }
	    return	
	}
    }


    # Save information about the core file.  You need to restore the
    # original tcl_platform environment because some of the tests mess
    # with tcl_platform.

    if {[preserveCore]} {
	set currentTclPlatform [array get tcl_platform]
	array set tcl_platform $originalTclPlatform
	if {[file exists [file join [workingDirectory] core]]} {
	    set coreModTime \
		    [file mtime [file join [workingDirectory] core]]
	}
	array set tcl_platform $currentTclPlatform
    }


    # If there is no "memory" command (because memory debugging isn't
    # enabled), then don't attempt to use the command.

    if {[llength [info commands memory]] == 1} {
	memory tag $name
    }

    if {[IsVerbose start]} {
	puts [outputChannel] "---- $name start"
	flush [outputChannel]
    }

    set code [catch {uplevel 1 $script} actualAnswer]

    return [list $actualAnswer $code]
}

#####################################################################








|


>
|
|
<
|
|
|
|
|
<
<
<
|
|
<
>








<
<
<
<
<







2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160

2161
2162
2163
2164
2165



2166
2167

2168
2169
2170
2171
2172
2173
2174
2175
2176





2177
2178
2179
2180
2181
2182
2183
		puts [outputChannel] "++++ $name SKIPPED: $constraints"
	    }

	    if {$testLevel == 1} {
		incr numTests(Skipped)
		AddToSkippedBecause $constraints
	    }
	    return 1
	}
    }
    return 0
}


# RunTest --
#
# This is where the body of a test is evaluated.  The combination of
# [RunTest] and [Eval] allows the output and error output of the test
# body to be captured for comparison against the expected values.




proc tcltest::RunTest {name script} {

    DebugPuts 3 "Running $name {$script}"

    # If there is no "memory" command (because memory debugging isn't
    # enabled), then don't attempt to use the command.

    if {[llength [info commands memory]] == 1} {
	memory tag $name
    }






    set code [catch {uplevel 1 $script} actualAnswer]

    return [list $actualAnswer $code]
}

#####################################################################

2410
2411
2412
2413
2414
2415
2416

2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429

2430
2431
2432
2433
2434
2435
2436
    variable failFiles
    variable skippedBecause
    variable currentFailure
    variable originalEnv
    variable originalTclPlatform
    variable coreModTime


    set testFileName [file tail [info script]]

    # Call the cleanup hook
    cleanupTestsHook

    # Remove files and directories created by the makeFile and
    # makeDirectory procedures.  Record the names of files in
    # workingDirectory that were not pre-existing, and associate them
    # with the test file that created them.

    if {!$calledFromAllFile} {
	foreach file $filesMade {
	    if {[file exists $file]} {

		catch {file delete -force $file}
	    }
	}
	set currentFiles {}
	foreach file [glob -nocomplain \
		-directory [temporaryDirectory] *] {
	    lappend currentFiles [file tail $file]







>













>







2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
    variable failFiles
    variable skippedBecause
    variable currentFailure
    variable originalEnv
    variable originalTclPlatform
    variable coreModTime

    FillFilesExisted
    set testFileName [file tail [info script]]

    # Call the cleanup hook
    cleanupTestsHook

    # Remove files and directories created by the makeFile and
    # makeDirectory procedures.  Record the names of files in
    # workingDirectory that were not pre-existing, and associate them
    # with the test file that created them.

    if {!$calledFromAllFile} {
	foreach file $filesMade {
	    if {[file exists $file]} {
		DebugDo 1 {Warn "cleanupTests deleting $file..."}
		catch {file delete -force $file}
	    }
	}
	set currentFiles {}
	foreach file [glob -nocomplain \
		-directory [temporaryDirectory] *] {
	    lappend currentFiles [file tail $file]
2503
2504
2505
2506
2507
2508
2509
2510
2511


2512
2513
2514
2515
2516
2517
2518
2519
2520

	set filesMade {}
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode

	global tk_version tcl_interactive


	if {![catch {package present Tk}]
		&& ![info exists tcl_interactive]} {
	    exit
	}
    } else {

	# if we're deferring stat-reporting until all files are sourced,
	# then add current file to failFile list if any tests in this
	# file failed







|
|
>
>
|
<







2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334

2335
2336
2337
2338
2339
2340
2341

	set filesMade {}
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    set numTests($index) 0
	}

	# exit only if running Tk in non-interactive mode
	# This should be changed to determine if an event
	# loop is running, which is the real issue.
	# Actually, this doesn't belong here at all.  A package
	# really has no business [exit]-ing an application.
	if {![catch {package present Tk}] && ![testConstraint interactive]} {

	    exit
	}
    } else {

	# if we're deferring stat-reporting until all files are sourced,
	# then add current file to failFile list if any tests in this
	# file failed
2628
2629
2630
2631
2632
2633
2634
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
#
# Side Effects:
#       None

# a lower case version is needed for compatibility with tcltest 1.0
proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}

proc tcltest::GetMatchingFiles { {searchDirectory ""} } {
    if {[llength [info level 0]] == 1} {


	set searchDirectory [testsDirectory]



    }

    set matchingFiles {}


    # Find the matching files in the list of directories and then remove
    # the ones that match the skip pattern. Passing a list to foreach is
    # required so that a patch like D:\Foo\Bar does not get munged into
    # D:FooBar.
    foreach directory [list $searchDirectory] {
	set matchFileList {}
	foreach match [matchFiles] {
	    set matchFileList [concat $matchFileList \
		    [glob -directory $directory -nocomplain -- $match]]
	}
	if {[string compare {} $tcltest::skipFiles]} {

	    set skipFileList {}
	    foreach skip [skipFiles] {
		set skipFileList [concat $skipFileList \
			[glob -directory $directory \
			-nocomplain -- $skip]]
	    }


	    foreach file $matchFileList {
		# Only include files that don't match the skip pattern
		# and aren't SCCS lock files.
		if {([lsearch -exact $skipFileList $file] == -1) && \
			(![string match l.*.test [file tail $file]])} {
		    lappend matchingFiles $file
		}
	    }
	} else {
	    set matchingFiles [concat $matchingFiles $matchFileList]
	}
    }
    if {[string equal $matchingFiles {}]} {
	PrintError "No test files remain after applying your match and\
		skip patterns!"
    }
    return $matchingFiles
}

# tcltest::GetMatchingDirectories --







|
|
>
>
|
>
>
>

>
|
>

<
<
<
<
|
|




|
>
|
|
|
|
<
|
>
>
|
<
<
|
<
|
|
|
<
<
|
|
|







2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468




2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480

2481
2482
2483
2484


2485

2486
2487
2488


2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
#
# Side Effects:
#       None

# a lower case version is needed for compatibility with tcltest 1.0
proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}

proc tcltest::GetMatchingFiles { args } {
    if {[llength $args]} {
	set dirList $args
    } else {
	# Finding tests only in [testsDirectory] is normal operation.
	# This procedure is written to accept multiple directory arguments
	# only to satisfy version 1 compatibility.
	set dirList [list [testsDirectory]]
    }

    set matchingFiles [list]
    foreach directory $dirList {





	# List files in $directory that match patterns to run.
	set matchFileList [list]
	foreach match [matchFiles] {
	    set matchFileList [concat $matchFileList \
		    [glob -directory $directory -nocomplain -- $match]]
	}

	# List files in $directory that match patterns to skip.
	set skipFileList [list]
	foreach skip [skipFiles] {
	    set skipFileList [concat $skipFileList \
		    [glob -directory $directory -nocomplain -- $skip]]

	}

	# Add to result list all files in match list and not in skip list
	foreach file $matchFileList {


	    if {[lsearch -exact $skipFileList $file] == -1} {

		lappend matchingFiles $file
	    }
	}


    }

    if {[llength $matchingFiles] == 0} {
	PrintError "No test files remain after applying your match and\
		skip patterns!"
    }
    return $matchingFiles
}

# tcltest::GetMatchingDirectories --
2688
2689
2690
2691
2692
2693
2694
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
#	The constructed list is returned to the user.  This is used in
#	the primary all.tcl file.
#
# Side Effects:
#       None.

proc tcltest::GetMatchingDirectories {rootdir} {
    set matchingDirs {}
    set matchDirList {}
    # Find the matching directories in testsDirectory and then remove

    # the ones that match the skip pattern
    foreach match [matchDirectories] {
	foreach file [glob -directory $rootdir -nocomplain -- $match] {
	    if {[file isdirectory $file]
		    && [string compare $file $rootdir]} {
		set matchDirList [concat $matchDirList \
			[GetMatchingDirectories $file]]
		if {[file exists [file join $file all.tcl]]} {
		    lappend matchDirList $file
		}
	    }
	}
    }
    if {[llength [skipDirectories]]} {


	set skipDirs {}
	foreach skip [skipDirectories] {
	    set skipDirs [concat $skipDirs \
		[glob -nocomplain -directory [testsDirectory] $skip]]
	}
	foreach dir $matchDirList {
	    # Only include directories that don't match the skip pattern
	    if {[lsearch -exact $skipDirs $dir] == -1} {



		lappend matchingDirs $dir
	    }
	}
    } else {
	set matchingDirs $matchDirList
    }



    if {[llength $matchingDirs] == 0} {
	DebugPuts 1 "No test directories remain after applying match\
		and skip patterns!"
    }
    return $matchingDirs
}

# tcltest::runAllTests --
#
#	prints output and sources test files according to the match and
#	skip patterns provided.  after sourcing test files, it goes on
#	to source all.tcl files in matching test subdirectories.
#
# Arguments:
#	shell being tested
#
# Results:
#	None.
#
# Side effects:
#	None.

proc tcltest::runAllTests { {shell ""} } {
    global argv
    variable testSingleFile
    variable numTestFiles
    variable numTests
    variable failFiles


    if {[llength [info level 0]] == 1} {
	set shell [interpreter]
    }

    set testSingleFile false

    puts [outputChannel] "Tests running in interp:  $shell"







|
|
|
>
|
|
|
|
<
<
<
<
|
|
|
|
|
<
>
>
|
|
<
|
<
<
|
|
>
>
>
|
|
|
<
<
|
>
>
>
|



|


















<





>







2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523




2524
2525
2526
2527
2528

2529
2530
2531
2532

2533


2534
2535
2536
2537
2538
2539
2540
2541


2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568

2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
#	The constructed list is returned to the user.  This is used in
#	the primary all.tcl file.
#
# Side Effects:
#       None.

proc tcltest::GetMatchingDirectories {rootdir} {

    # Determine the skip list first, to avoid [glob]-ing over subdirectories
    # we're going to throw away anyway.  Be sure we skip the $rootdir if it
    # comes up to avoid infinite loops.
    set skipDirs [list $rootdir]
    foreach pattern [skipDirectories] {
	foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
	    if {[file isdirectory $path]} {




		lappend skipDirs $path
	    }
	}
    }


    # Now step through the matching directories, prune out the skipped ones
    # as you go.
    set matchDirs [list]
    foreach pattern [matchDirectories] {

	foreach path [glob -directory $rootdir -nocomplain -- $pattern] {


	    if {[file isdirectory $path]} {
		if {[lsearch -exact $skipDirs $path] == -1} {
		    set matchDirs [concat $matchDirs \
			    [GetMatchingDirectories $path]]
		    if {[file exists [file join $path all.tcl]]} {
			lappend matchDirs $path
		    }
		}


	    }
	}
    }

    if {[llength $matchDirs] == 0} {
	DebugPuts 1 "No test directories remain after applying match\
		and skip patterns!"
    }
    return $matchDirs
}

# tcltest::runAllTests --
#
#	prints output and sources test files according to the match and
#	skip patterns provided.  after sourcing test files, it goes on
#	to source all.tcl files in matching test subdirectories.
#
# Arguments:
#	shell being tested
#
# Results:
#	None.
#
# Side effects:
#	None.

proc tcltest::runAllTests { {shell ""} } {

    variable testSingleFile
    variable numTestFiles
    variable numTests
    variable failFiles

    FillFilesExisted
    if {[llength [info level 0]] == 1} {
	set shell [interpreter]
    }

    set testSingleFile false

    puts [outputChannel] "Tests running in interp:  $shell"
2780
2781
2782
2783
2784
2785
2786
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
    } else {
	puts [outputChannel] \
		"Test files run in separate interpreters"
    }
    if {[llength [skip]] > 0} {
	puts [outputChannel] "Skipping tests that match:  [skip]"
    }
    if {[llength [match]] > 0} {
	puts [outputChannel] "Only running tests that match:  [match]"
    }

    if {[llength [skipFiles]] > 0} {
	puts [outputChannel] \
		"Skipping test files that match:  [skipFiles]"
    }
    if {[llength [matchFiles]] > 0} {
	puts [outputChannel] \
		"Only running test files that match:  [matchFiles]"
    }

    set timeCmd {clock format [clock seconds]}
    puts [outputChannel] "Tests began at [eval $timeCmd]"

    # Run each of the specified tests
    foreach file [lsort [GetMatchingFiles]] {
	set tail [file tail $file]
	puts [outputChannel] $tail


	if {[singleProcess]} {
	    incr numTestFiles
	    uplevel 1 [list ::source $file]
	} else {








	    set cmd [linsert $argv 0 | $shell $file]
	    if {[catch {
		incr numTestFiles
		set pipeFd [open $cmd "r"]
		while {[gets $pipeFd line] >= 0} {
		    if {[regexp [join {
			    {^([^:]+):\t}
			    {Total\t([0-9]+)\t}







<
|
<

















>





>
>
>
>
>
>
>
>
|







2600
2601
2602
2603
2604
2605
2606

2607

2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
    } else {
	puts [outputChannel] \
		"Test files run in separate interpreters"
    }
    if {[llength [skip]] > 0} {
	puts [outputChannel] "Skipping tests that match:  [skip]"
    }

    puts [outputChannel] "Running tests that match:  [match]"


    if {[llength [skipFiles]] > 0} {
	puts [outputChannel] \
		"Skipping test files that match:  [skipFiles]"
    }
    if {[llength [matchFiles]] > 0} {
	puts [outputChannel] \
		"Only running test files that match:  [matchFiles]"
    }

    set timeCmd {clock format [clock seconds]}
    puts [outputChannel] "Tests began at [eval $timeCmd]"

    # Run each of the specified tests
    foreach file [lsort [GetMatchingFiles]] {
	set tail [file tail $file]
	puts [outputChannel] $tail
	flush [outputChannel]

	if {[singleProcess]} {
	    incr numTestFiles
	    uplevel 1 [list ::source $file]
	} else {
	    # Pass along our configuration to the child processes.
	    # EXCEPT for the -outfile, because the parent process
	    # needs to read and process output of children.
	    set childargv [list]
	    foreach opt [Configure] {
		if {[string equal $opt -outfile]} {continue}
		lappend childargv $opt [Configure $opt]
	    }
	    set cmd [linsert $childargv 0 | $shell $file]
	    if {[catch {
		incr numTestFiles
		set pipeFd [open $cmd "r"]
		while {[gets $pipeFd line] >= 0} {
		    if {[regexp [join {
			    {^([^:]+):\t}
			    {Total\t([0-9]+)\t}
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866

    # cleanup
    puts [outputChannel] "\nTests ended at [eval $timeCmd]"
    cleanupTests 1
    if {[info exists testFileFailures]} {
	puts [outputChannel] "\nTest files exiting with errors:  \n"
	foreach file $testFileFailures {
	    puts "  [file tail $file]\n"
	}
    }

    # Checking for subdirectories in which to run tests
    foreach directory [GetMatchingDirectories [testsDirectory]] {
	set dir [file tail $directory]
	puts [outputChannel] [string repeat ~ 44]







|







2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693

    # cleanup
    puts [outputChannel] "\nTests ended at [eval $timeCmd]"
    cleanupTests 1
    if {[info exists testFileFailures]} {
	puts [outputChannel] "\nTest files exiting with errors:  \n"
	foreach file $testFileFailures {
	    puts [outputChannel] "  [file tail $file]\n"
	}
    }

    # Checking for subdirectories in which to run tests
    foreach directory [GetMatchingDirectories [testsDirectory]] {
	set dir [file tail $directory]
	puts [outputChannel] [string repeat ~ 44]
2998
2999
3000
3001
3002
3003
3004
3005
3006

3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
# Results:
#	absolute path to the file created
#
# Side effects:
#	None.

proc tcltest::makeFile {contents name {directory ""}} {
    global tcl_platform
    variable filesMade


    if {[llength [info level 0]] == 3} {
	set directory [temporaryDirectory]
    }

    set fullName [file join $directory $name]

    DebugPuts 3 "[lindex [info level 0] 0]:\
	     putting $contents into $fullName"

    set fd [open $fullName w]

    fconfigure $fd -translation lf

    if {[string equal [string index $contents end] "\n"]} {
	puts -nonewline $fd $contents
    } else {
	puts $fd $contents
    }
    close $fd

    if {[lsearch -exact $filesMade $fullName] == -1} {







<

>








|


<

<
|







2825
2826
2827
2828
2829
2830
2831

2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844

2845

2846
2847
2848
2849
2850
2851
2852
2853
# Results:
#	absolute path to the file created
#
# Side effects:
#	None.

proc tcltest::makeFile {contents name {directory ""}} {

    variable filesMade
    FillFilesExisted

    if {[llength [info level 0]] == 3} {
	set directory [temporaryDirectory]
    }

    set fullName [file join $directory $name]

    DebugPuts 3 "[lindex [info level 0] 0]:\
	     putting ``$contents'' into $fullName"

    set fd [open $fullName w]

    fconfigure $fd -translation lf

    if {[string equal [string index $contents end] \n]} {
	puts -nonewline $fd $contents
    } else {
	puts $fd $contents
    }
    close $fd

    if {[lsearch -exact $filesMade $fullName] == -1} {
3042
3043
3044
3045
3046
3047
3048


3049
3050
3051
3052
3053












3054
3055
3056
3057
3058
3059
3060
# Results:
#	return value from [file delete]
#
# Side effects:
#	None.

proc tcltest::removeFile {name {directory ""}} {


    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"












    return [file delete $fullName]
}

# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#







>
>





>
>
>
>
>
>
>
>
>
>
>
>







2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
# Results:
#	return value from [file delete]
#
# Side effects:
#	None.

proc tcltest::removeFile {name {directory ""}} {
    variable filesMade
    FillFilesExisted
    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
    set idx [lsearch -exact $filesMade $fullName]
    set filesMade [lreplace $filesMade $idx $idx]
    if {$idx == -1} {
	DebugDo 1 {
	    Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
	}
    } 
    if {![file isfile $fullName]} {
	DebugDo 1 {
	    Warn "removeFile removing \"$fullName\":\n  not a file"
	}
    }
    return [file delete $fullName]
}

# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#
3070
3071
3072
3073
3074
3075
3076

3077
3078
3079
3080
3081
3082
3083
#	absolute path to the directory created
#
# Side effects:
#	None.

proc tcltest::makeDirectory {name {directory ""}} {
    variable filesMade

    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
    file mkdir $fullName
    if {[lsearch -exact $filesMade $fullName] == -1} {







>







2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
#	absolute path to the directory created
#
# Side effects:
#	None.

proc tcltest::makeDirectory {name {directory ""}} {
    variable filesMade
    FillFilesExisted
    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
    file mkdir $fullName
    if {[lsearch -exact $filesMade $fullName] == -1} {
3097
3098
3099
3100
3101
3102
3103


3104
3105
3106
3107
3108













3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
# Results:
#	return value from [file delete]
#
# Side effects:
#	None

proc tcltest::removeDirectory {name {directory ""}} {


    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"













    return [file delete -force $fullName]
}

# tcltest::viewFile --
#
#	reads the content of a file and returns it
#
# Arguments:
#	name of the file to read
#       directory in which file is located
#
# Results:
#	content of the named file
#
# Side effects:
#	None.

proc tcltest::viewFile {name {directory ""}} {
    global tcl_platform
    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    if {[string equal $tcl_platform(platform) macintosh]
	    || ![testConstraint unixExecs]} {
	set f [open $fullName]
	set data [read -nonewline $f]
	close $f
	return $data
    } else {
	return [exec cat $fullName]
    }
    return
}

# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to







>
>





>
>
>
>
>
>
>
>
>
>
>
>
>


















|




<
<
|
|
|
|
<
<
<
<







2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986


2987
2988
2989
2990




2991
2992
2993
2994
2995
2996
2997
# Results:
#	return value from [file delete]
#
# Side effects:
#	None

proc tcltest::removeDirectory {name {directory ""}} {
    variable filesMade
    FillFilesExisted
    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]
    DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
    set idx [lsearch -exact $filesMade $fullName]
    set filesMade [lreplace $filesMade $idx $idx]
    if {$idx == -1} {
	DebugDo 1 {
	    Warn "removeDirectory removing \"$fullName\":\n  not created\
		    by makeDirectory"
	}
    } 
    if {![file isdirectory $fullName]} {
	DebugDo 1 {
	    Warn "removeDirectory removing \"$fullName\":\n  not a directory"
	}
    }
    return [file delete -force $fullName]
}

# tcltest::viewFile --
#
#	reads the content of a file and returns it
#
# Arguments:
#	name of the file to read
#       directory in which file is located
#
# Results:
#	content of the named file
#
# Side effects:
#	None.

proc tcltest::viewFile {name {directory ""}} {
    FillFilesExisted
    if {[llength [info level 0]] == 2} {
	set directory [temporaryDirectory]
    }
    set fullName [file join $directory $name]


    set f [open $fullName]
    set data [read -nonewline $f]
    close $f
    return $data




}

# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361









3362




3363








































3364
3365
    # straight away, without all this "hook" nonsense.
    if {[string equal [namespace current] \
	    [namespace qualifiers [namespace which initConstraintsHook]]]} {
	InitConstraints
    } else {
	proc initConstraintsHook {} {}
    }
    ProcessCmdLineArgs

    # Save the names of files that already exist in
    # the output directory.
    variable file {}
    foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
	lappend filesExisted [file tail $file]
    }

    # Define the standard match commands
    customMatch exact	[list string equal]
    customMatch glob	[list string match]
    customMatch regexp	[list regexp --]
    unset file









}













































package provide tcltest 2.1








<

<
<
<
<
<
<
<




|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
3190
3191
3192
3193
3194
3195
3196

3197







3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
    # straight away, without all this "hook" nonsense.
    if {[string equal [namespace current] \
	    [namespace qualifiers [namespace which initConstraintsHook]]]} {
	InitConstraints
    } else {
	proc initConstraintsHook {} {}
    }









    # Define the standard match commands
    customMatch exact	[list string equal]
    customMatch glob	[list string match]
    customMatch regexp	[list regexp --]

    # If the TCLTEST_OPTIONS environment variable exists, configure
    # tcltest according to the option values it specifies.  This has
    # the effect of resetting tcltest's default configuration.
    proc ConfigureFromEnvironment {} {
	upvar #0 env(TCLTEST_OPTIONS) options
	if {[catch {llength $options} msg]} {
	    Warn "invalid TCLTEST_OPTIONS \"$options\":\n  invalid\
		    Tcl list: $msg"
	    return
	}
	if {[llength $::env(TCLTEST_OPTIONS)] < 2} {
	    Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  should be\
		    -option value ?-option value ...?"
	    return
	}
	if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} {
	    Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  $msg"
	    return
	}
    }
    if {[info exists ::env(TCLTEST_OPTIONS)]} {
	ConfigureFromEnvironment
    }

    proc LoadTimeCmdLineArgParsingRequired {} {
	set required false
	if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
	    # The command line asks for -help, so give it (and exit)
	    # right now.  ([configure] does not process -help)
	    set required true
	}
	foreach hook { PrintUsageInfoHook processCmdLineArgsHook
			processCmdLineArgsAddFlagsHook } {
	    if {[string equal [namespace current] [namespace qualifiers \
		    [namespace which $hook]]]} {
		set required true
	    } else {
		proc $hook args {}
	    }
	}
	return $required
    }

    # Only initialize configurable options from the command line arguments
    # at package load time if necessary for backward compatibility.  This
    # lets the tcltest user call [configure] for themselves if they wish.
    # Traces are established for auto-configuration from the command line
    # if any configurable options are accessed before the user calls
    # [configure].
    if {[LoadTimeCmdLineArgParsingRequired]} {
	ProcessCmdLineArgs
    } else {
	EstablishAutoConfigureTraces
    }

    package provide [namespace tail [namespace current]] $Version
}
Changes to license.terms.
1
2
3
4

5
6
7
8
9
10
11
This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation,
and other parties.  The following terms apply to all files associated
with the software unless explicitly disclaimed in individual files.


The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors

|
|
|
>







1
2
3
4
5
6
7
8
9
10
11
12
This software is copyrighted by the Regents of the University of
California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
Corporation and other parties.  The following terms apply to all files
associated with the software unless explicitly disclaimed in
individual files.

The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
Changes to mac/tclMacChan.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclMacChan.c
 *
 *	Channel drivers for Macintosh channels for the
 *	console fds.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacChan.c,v 1.7.8.2 2002/06/10 05:33:14 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclMacInt.h"
#include <Aliases.h>
#include <Errors.h>











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclMacChan.c
 *
 *	Channel drivers for Macintosh channels for the
 *	console fds.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacChan.c,v 1.7.8.3 2002/08/20 20:25:27 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclMacInt.h"
#include <Aliases.h>
#include <Errors.h>
737
738
739
740
741
742
743
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
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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_Channel chan;
    int mode;
    CONST char *native;
    int errorCode;
    
    mode = GetOpenMode(interp, modeString);
    if (mode == -1) {
	return NULL;
    }

    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	return NULL;
    }
    chan = OpenFileChannel(native, mode, permissions, &errorCode);

    if (chan == NULL) {







|

















|
<





<



<
<
<
<
<







737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762

763
764
765
766
767

768
769
770





771
772
773
774
775
776
777
}

/*
 *----------------------------------------------------------------------
 *
 * TclpOpenFileChannel --
 *
 *	Open a File based channel on MacOS systems.
 *
 * Results:
 *	The new channel or NULL. If NULL, the output argument
 *	errorCodePtr is set to a POSIX error.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(
    Tcl_Interp *interp,			/* Interpreter for error reporting;
                                         * can be NULL. */
    Tcl_Obj *pathPtr,			/* Name of file to open. */
    int mode,				/* POSIX open mode. */

    int permissions)			/* If the open involves creating a
                                         * file, with what modes to create
                                         * it? */
{
    Tcl_Channel chan;

    CONST char *native;
    int errorCode;
    





    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	return NULL;
    }
    chan = OpenFileChannel(native, mode, permissions, &errorCode);

    if (chan == NULL) {
Changes to mac/tclMacFile.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclMacFile.c --
 *
 *      This file implements the channel drivers for Macintosh
 *	files.  It also comtains Macintosh version of other Tcl
 *	functions that deal with the file system.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacFile.c,v 1.12.8.2 2002/06/10 05:33:14 wolfsuit Exp $
 */

/*
 * Note: This code eventually needs to support async I/O.  In doing this
 * we will need to keep track of all current async I/O.  If exit to shell
 * is called - we shouldn't exit until all asyc I/O completes.
 */












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclMacFile.c --
 *
 *      This file implements the channel drivers for Macintosh
 *	files.  It also comtains Macintosh version of other Tcl
 *	functions that deal with the file system.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacFile.c,v 1.12.8.3 2002/08/20 20:25:27 das Exp $
 */

/*
 * Note: This code eventually needs to support async I/O.  In doing this
 * we will need to keep track of all current async I/O.  If exit to shell
 * is called - we shouldn't exit until all asyc I/O completes.
 */
682
683
684
685
686
687
688
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
    
    Tcl_UtfToExternalDString(NULL, path, -1, &ds);

    /*
     * Remove ending colons if they exist.
     */
     
    while ((Tcl_DStringLength(&ds) != 0) && (Tcl_DStringValue(&ds)[Tcl_DStringLength(&ds) - 1] == ':')) {

	Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 1);
    }

    end = strrchr(Tcl_DStringValue(&ds), ':');
    if (end == NULL ) {
	strcpy(fileName + 1, Tcl_DStringValue(&ds));
    } else {
	strcpy(fileName + 1, end + 1);
	Tcl_DStringSetLength(&ds, end + 1 - Tcl_DStringValue(&ds));
    }
    fileName[0] = (char) strlen(fileName + 1);
    
    /*
     * Create the file spec for the directory of the file
     * we want to look at.
     */

    if (end != NULL) {
	err = FSpLocationFromPath(Tcl_DStringLength(&ds), Tcl_DStringValue(&ds), &fileSpec);

	if (err != noErr) {
	    Tcl_DStringFree(&ds);
	    errno = EINVAL;
	    return NULL;
	}
    } else {
	FSMakeFSSpecCompat(0, 0, NULL, &fileSpec);







|
>


















|
>







682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
    
    Tcl_UtfToExternalDString(NULL, path, -1, &ds);

    /*
     * Remove ending colons if they exist.
     */
     
    while ((Tcl_DStringLength(&ds) != 0) 
	   && (Tcl_DStringValue(&ds)[Tcl_DStringLength(&ds) - 1] == ':')) {
	Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 1);
    }

    end = strrchr(Tcl_DStringValue(&ds), ':');
    if (end == NULL ) {
	strcpy(fileName + 1, Tcl_DStringValue(&ds));
    } else {
	strcpy(fileName + 1, end + 1);
	Tcl_DStringSetLength(&ds, end + 1 - Tcl_DStringValue(&ds));
    }
    fileName[0] = (char) strlen(fileName + 1);
    
    /*
     * Create the file spec for the directory of the file
     * we want to look at.
     */

    if (end != NULL) {
	err = FSpLocationFromPath(Tcl_DStringLength(&ds), 
				  Tcl_DStringValue(&ds), &fileSpec);
	if (err != noErr) {
	    Tcl_DStringFree(&ds);
	    errno = EINVAL;
	    return NULL;
	}
    } else {
	FSMakeFSSpecCompat(0, 0, NULL, &fileSpec);
770
771
772
773
774
775
776
777

778
779
780
781
782
783
784
    Tcl_ExternalToUtfDString(NULL, *theString, pathSize, linkPtr);
    DisposeHandle(theString);
    
    return Tcl_DStringValue(linkPtr);
}

static int 
TclpObjStatAlias _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr, Boolean resolveLink));



/*
 *----------------------------------------------------------------------
 *
 * TclpObjLstat --
 *







|
>







772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
    Tcl_ExternalToUtfDString(NULL, *theString, pathSize, linkPtr);
    DisposeHandle(theString);
    
    return Tcl_DStringValue(linkPtr);
}

static int 
TclpObjStatAlias _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr, 
			      Boolean resolveLink));


/*
 *----------------------------------------------------------------------
 *
 * TclpObjLstat --
 *
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150

1151
1152
1153
1154



1155





































1156
1157
1158
1159
1160
1161
1162

    return TclpNativeToNormalized((ClientData) fileName);
}

#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;

{
    Tcl_Obj* link = NULL;

    if (toPtr != NULL) {



	return NULL;





































    } else {
	Tcl_DString ds;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    return NULL;
	}
	if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) {







|


>




>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206

    return TclpNativeToNormalized((ClientData) fileName);
}

#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    Tcl_Obj* link = NULL;

    if (toPtr != NULL) {
	if (TclpObjAccess(pathPtr, F_OK) != -1) {
	    /* src exists */
	    errno = EEXIST;
	    return NULL;
	}
	if (TclpObjAccess(toPtr, F_OK) == -1) {
	    /* target doesn't exist */
	    errno = ENOENT;
	    return NULL;
	}

	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    /* Needs to create a new link */
	    FSSpec spec;
	    FSSpec linkSpec;
	    OSErr err;
	    char *path;
	    AliasHandle alias;
	    
	    err = FspLocationFromFsPath(toPtr, &spec);
	    if (err != noErr) {
		errno = ENOENT;
		return NULL;
	    }

	    path = Tcl_FSGetNativePath(pathPtr);
	    err = FSpLocationFromPath(strlen(path), path, &linkSpec);
	    if (err == noErr) {
		err = dupFNErr;		/* EEXIST. */
	    } else {
		err = NewAlias(&spec, &linkSpec, &alias);
	    }
	    if (err != noErr) {
		errno = TclMacOSErrorToPosixError(err);
		return NULL;
	    }
	    return toPtr;
	} else {
	    errno = ENODEV;
	    return NULL;
	}
    } else {
	Tcl_DString ds;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    return NULL;
	}
	if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) {
Changes to mac/tclMacLoad.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclMacLoad.c --
 *
 *	This procedure provides a version of the TclLoadFile for use
 *	on the Macintosh.  This procedure will only work with systems 
 *	that use the Code Fragment Manager.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacLoad.c,v 1.7.2.1 2002/02/05 02:22:02 wolfsuit Exp $
 */

#include <CodeFragments.h>
#include <Errors.h>
#include <Resources.h>
#include <Strings.h>
#include <FSpCompat.h>












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclMacLoad.c --
 *
 *	This procedure provides a version of the TclLoadFile for use
 *	on the Macintosh.  This procedure will only work with systems 
 *	that use the Code Fragment Manager.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacLoad.c,v 1.7.2.2 2002/08/20 20:25:27 das Exp $
 */

#include <CodeFragments.h>
#include <Errors.h>
#include <Resources.h>
#include <Strings.h>
#include <FSpCompat.h>
72
73
74
75
76
77
78



















79
80
81
82
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
    long	codeLength;
    long	res1;
    long	res2;
    short	itemSize;
    Str255	name;		/* This is actually variable sized. */
};
typedef struct CfrgItem CfrgItem;




















/*
 *----------------------------------------------------------------------
 *
 * TclLoadFile --
 *
 *	This procedure is called to carry out dynamic loading of binary
 *	code for the Macintosh.  This implementation is based on the
 *	Code Fragment Manager & will not work on other systems.
 *
 * Results:
 *	The result is TCL_ERROR, and an error message is left in
 *	the interp's result.
 *
 * Side effects:
 *	New binary code is loaded.
 *
 *----------------------------------------------------------------------
 */

int
TclpLoadFile(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Obj *pathPtr,		/* Name of the file containing the desired
				 * code. */
    CONST char *sym1,
    CONST char *sym2,		/* Names of two procedures to look up in
				 * the file's symbol table. */
    Tcl_PackageInitProc **proc1Ptr,
    Tcl_PackageInitProc **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. */
{
    CFragConnectionID connID;
    Ptr dummy;
    OSErr err;
    CFragSymbolClass symClass;
    FSSpec fileSpec;
    short fragFileRef, saveFileRef;
    Handle fragResource;
    UInt32 offset = 0;
    UInt32 length = kCFragGoesToEOF;
    StringPtr fragName=NULL;
    Str255 errName, symbolName;
    Tcl_DString ds;
    CONST char *native;

    
    native = Tcl_FSGetNativePath(pathPtr);
    err = FSpLocationFromPath(strlen(native), native, &fileSpec);
    
    if (err != noErr) {
	Tcl_SetResult(interp, "could not locate shared library", TCL_STATIC);
	return TCL_ERROR;
    }
    















    /*
     * First thing we must do is infer the package name from the sym1
     * variable (by removing the "_Init" suffix).  This is kind of dumb
     * since the caller actually knows this value, it just doesn't give


     * it to us.
     */


    native = Tcl_UtfToExternalDString(NULL, sym1, -1, &ds);









    Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 5);


    

    /*
     * See if this fragment has a 'cfrg' resource.  It will tell us where
     * to look for the fragment in the file.  If it doesn't exist we will
     * assume we have a ppc frag using the whole data fork.  If it does
     * exist we find the frag that matches the one we are looking for and
     * get the offset and size from the resource.
     */
     
    saveFileRef = CurResFile();
    SetResLoad(false);
    fragFileRef = FSpOpenResFile(&fileSpec, fsRdPerm);
    SetResLoad(true);
    if (fragFileRef != -1) {

	UseResFile(fragFileRef);
	fragResource = Get1Resource(kCFragResourceType, kCFragResourceID);
	HLock(fragResource);
	if (ResError() == noErr) {
	    CfrgItem* srcItem;
	    long itemCount, index;
	    Ptr itemStart;

	    itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount;
	    itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart;
	    for (index = 0; index < itemCount;
		 index++, itemStart += srcItem->itemSize) {
		srcItem = (CfrgItem*)itemStart;
		if (srcItem->archType != OUR_ARCH_TYPE) continue;
		if (!strncasecmp(native, (char *) srcItem->name + 1,
			strlen(native))) {
		    offset = srcItem->codeOffset;
		    length = srcItem->codeLength;
		    fragName=srcItem->name;

		}
	    }
	}
	/*
	 * Close the resource file.  If the extension wants to reopen the
	 * resource fork it should use the tclMacLibrary.c file during it's
	 * construction.
	 */
	HUnlock(fragResource);
	ReleaseResource(fragResource);
	CloseResFile(fragFileRef);
	UseResFile(saveFileRef);



    }
    Tcl_DStringFree(&ds);


    /*
     * Now we can attempt to load the fragement using the offset & length
     * obtained from the resource.  We don't worry about the main entry point
     * as we are going to search for specific entry points passed to us.
     */
    
    err = GetDiskFragment(&fileSpec, offset, length, fragName,
	    kLoadCFrag, &connID, &dummy, errName);

    *clientDataPtr = (ClientData) connID;

    if (err != fragNoErr) {
	p2cstr(errName);
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", errName, (char *) NULL);
	return TCL_ERROR;
    }
    


    *unloadProcPtr = &TclpUnloadFile;

   



































    Tcl_UtfToExternalDString(NULL, sym1, -1, &ds);









    strcpy((char *) symbolName + 1, Tcl_DStringValue(&ds));
    symbolName[0] = (unsigned) Tcl_DStringLength(&ds);
    err = FindSymbol(connID, symbolName, (Ptr *) proc1Ptr, &symClass);
    Tcl_DStringFree(&ds);
    if (err != fragNoErr || symClass == kDataCFragSymbol) {
	Tcl_SetResult(interp,
		"could not find Initialization routine in library",
		TCL_STATIC);
	return TCL_ERROR;
    }

    Tcl_UtfToExternalDString(NULL, sym2, -1, &ds);
    strcpy((char *) symbolName + 1, Tcl_DStringValue(&ds));
    symbolName[0] = (unsigned) Tcl_DStringLength(&ds);
    err = FindSymbol(connID, symbolName, (Ptr *) proc2Ptr, &symClass);
    Tcl_DStringFree(&ds);
    if (err != fragNoErr || symClass == kDataCFragSymbol) {
	*proc2Ptr = NULL;
    }
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|
















|
|
|
|
<
<
<
<
<
<
<
|







<
<

<

<
<
<
<
<
<


>









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
>
>
|
|
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
|
>













>
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
>












>
>
>
|
<
|
>

|






|
<
<







|
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>


|





|

<
<
<
<
<
<
<
<
<
<
|







72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122







123
124
125
126
127
128
129
130


131

132






133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160



161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231

232
233
234
235
236
237
238
239
240
241
242


243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310










311
312
313
314
315
316
317
318
    long	codeLength;
    long	res1;
    long	res2;
    short	itemSize;
    Str255	name;		/* This is actually variable sized. */
};
typedef struct CfrgItem CfrgItem;

/*
 * On MacOS, old shared libraries which contain many code fragments
 * cannot, it seems, be loaded in one go.  We need to look provide
 * the name of a code fragment while we load.  Since with the
 * separation of the 'load' and 'findsymbol' be do not necessarily
 * know a symbol name at load time, we have to store some further
 * information in a structure like this so we can ensure we load
 * properly in 'findsymbol' if the first attempts didn't work.
 */
typedef struct TclMacLoadInfo {
    int loaded;
    CFragConnectionID connID;
    FSSpec fileSpec;
} TclMacLoadInfo;

static int TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo, 
		     CONST char *sym /* native */) 


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	This procedure is called to carry out dynamic loading of binary
 *	code for the Macintosh.  This implementation is based on the
 *	Code Fragment Manager & will not work on other systems.
 *
 * Results:
 *	The result is TCL_ERROR, and an error message is left in
 *	the interp's result.
 *
 * Side effects:
 *	New binary code is loaded.
 *
 *----------------------------------------------------------------------
 */

int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */







    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr)
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{


    OSErr err;

    FSSpec fileSpec;






    Tcl_DString ds;
    CONST char *native;
    TclMacLoadInfo *loadInfo;
    
    native = Tcl_FSGetNativePath(pathPtr);
    err = FSpLocationFromPath(strlen(native), native, &fileSpec);
    
    if (err != noErr) {
	Tcl_SetResult(interp, "could not locate shared library", TCL_STATIC);
	return TCL_ERROR;
    }
    
    loadInfo = (TclMacLoadInfo *) ckalloc(sizeof(TclMacLoadInfo));
    loadInfo->loaded = 0;
    loadInfo->fileSpec = fileSpec;
    loadInfo->connID = NULL;
    
    if (TryToLoad(interp, loadInfo, NULL) != TCL_OK) {
	ckfree(loadInfo);
	return TCL_ERROR;
    }

    *loadHandle = (Tcl_LoadHandle)loadInfo;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/* 



 * See the comments about 'struct TclMacLoadInfo' above. This
 * function ensures the appropriate library or symbol is
 * loaded.
 */
static int
TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo, 
	  CONST char *sym /* native */) 
{
    CFragConnectionID connID;
    Ptr dummy;
    short fragFileRef, saveFileRef;
    Handle fragResource;
    UInt32 offset = 0;
    UInt32 length = kCFragGoesToEOF;
    Str255 errName;
    StringPtr fragName=NULL;

    if (loadInfo->loaded == 1) {
        return TCL_OK;
    }

    /*
     * See if this fragment has a 'cfrg' resource.  It will tell us where
     * to look for the fragment in the file.  If it doesn't exist we will
     * assume we have a ppc frag using the whole data fork.  If it does
     * exist we find the frag that matches the one we are looking for and
     * get the offset and size from the resource.
     */
     
    saveFileRef = CurResFile();
    SetResLoad(false);
    fragFileRef = FSpOpenResFile(&fileSpec, fsRdPerm);
    SetResLoad(true);
    if (fragFileRef != -1) {
	if (sym != NULL) {
	    UseResFile(fragFileRef);
	    fragResource = Get1Resource(kCFragResourceType, kCFragResourceID);
	    HLock(fragResource);
	    if (ResError() == noErr) {
		CfrgItem* srcItem;
		long itemCount, index;
		Ptr itemStart;

		itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount;
		itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart;
		for (index = 0; index < itemCount;
		     index++, itemStart += srcItem->itemSize) {
		    srcItem = (CfrgItem*)itemStart;
		    if (srcItem->archType != OUR_ARCH_TYPE) continue;
		    if (!strncasecmp(sym, (char *) srcItem->name + 1,
			    strlen(sym))) {
			offset = srcItem->codeOffset;
			length = srcItem->codeLength;
			fragName=srcItem->name;
		    }
		}
	    }
	}
	/*
	 * Close the resource file.  If the extension wants to reopen the
	 * resource fork it should use the tclMacLibrary.c file during it's
	 * construction.
	 */
	HUnlock(fragResource);
	ReleaseResource(fragResource);
	CloseResFile(fragFileRef);
	UseResFile(saveFileRef);
	if (sym == NULL) {
	    /* We just return */
	    return TCL_OK;
	}

    }

    /*
     * Now we can attempt to load the fragment using the offset & length
     * obtained from the resource.  We don't worry about the main entry point
     * as we are going to search for specific entry points passed to us.
     */
    
    err = GetDiskFragment(&fileSpec, offset, length, fragName,
	    kLoadCFrag, &connID, &dummy, errName);
    


    if (err != fragNoErr) {
	p2cstr(errName);
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", errName, (char *) NULL);
	return TCL_ERROR;
    }

    loadInfo->connID = connID;
    loadInfo->loaded = 1;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_DString ds;
    Tcl_PackageInitProc *proc=NULL;
    TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;
    Str255 symbolName;
    CFragSymbolClass symClass;
    OSErr err;
   
    if (loadInfo->loaded == 0) {
	int res;
	/*
	 * First thing we must do is infer the package name from the
	 * sym variable.  We do this by removing the '_Init'.
	 */
	Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
	Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 5);
	res = TryToLoad(interp, loadInfo, Tcl_DStringValue(&ds));
	Tcl_DStringFree(&ds);
	if (res != TCL_OK) {
	    return NULL;
	}
    }
    
    Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    strcpy((char *) symbolName + 1, Tcl_DStringValue(&ds));
    symbolName[0] = (unsigned) Tcl_DStringLength(&ds);
    err = FindSymbol(loadInfo->connID, symbolName, (Ptr *) &proc, &symClass);
    Tcl_DStringFree(&ds);
    if (err != fragNoErr || symClass == kDataCFragSymbol) {
	Tcl_SetResult(interp,
		"could not find Initialization routine in library",
		TCL_STATIC);
	return NULL;
    }










    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
254
255
256
257
258
259
260
261
262
263
264
265
266


267


268
269
270
271
272
273
274
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{


    CloseConnection((CFragConnectionID*) &clientData);


}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *







|
|
|



>
>
|
>
>







326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;
    if (loadInfo->loaded) {
	CloseConnection((CFragConnectionID*) &(loadInfo->connID));
    }
    ckfree(loadInfo);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
Changes to mac/tclMacTest.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
/* 
 * tclMacTest.c --
 *
 *	Contains commands for platform specific tests for
 *	the Macintosh platform.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacTest.c,v 1.4 1999/05/11 07:13:36 jingham Exp $
 */

#define TCL_TEST

#include "tclInt.h"
#include "tclMacInt.h"
#include "tclMacPort.h"
#include "Files.h"
#include <Errors.h>
#include <Resources.h>
#include <Script.h>











|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
/* 
 * tclMacTest.c --
 *
 *	Contains commands for platform specific tests for
 *	the Macintosh platform.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacTest.c,v 1.4.28.1 2002/08/20 20:25:27 das Exp $
 */

#define TCL_TEST
#define USE_COMPAT_CONST
#include "tclInt.h"
#include "tclMacInt.h"
#include "tclMacPort.h"
#include "Files.h"
#include <Errors.h>
#include <Resources.h>
#include <Script.h>
Changes to macosx/Tcl.pbproj/jingham.pbxuser.
1
2
















3
4
5
6
7
8
9
10
11
12


























































































































13
14
15
16
17
18
19
20
21





22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
// !$*UTF8*$!
{
















	00E2F845016E82EB0ACA28DC = {
		activeBuildStyle = 00E2F847016E82EB0ACA28DC;
		activeTarget = F50DC359017027D801DC9062;
		addToTargets = (
			00E2F84C016E8B780ACA28DC,
		);
		breakpoints = (
		);
		perUserDictionary = {
			PBXPerProjectTemplateStateSaveDate = 45284653;


























































































































			PBXWorkspaceContents = (
				{
					LeftSlideOut = {
						Split0 = {
							Split0 = {
								NavContent0 = {
									bookmark = F5A8CC2B02B2FBA001DC9062;
									history = (
										F55BC4B702B2E09001DC9062,





									);
								};
								NavCount = 1;
								NavGeometry0 = {
									Frame = "{{0, 0}, {571, 548}}";
									NavBarVisible = YES;
								};
							};
							SplitCount = 1;
							Tab0 = {
								Debugger = {
									Split0 = {
										SplitCount = 2;
									};
									SplitCount = 1;
									TabCount = 2;
								};
								LauncherConfigVersion = 7;
							};
							Tab1 = {
								LauncherConfigVersion = 3;
								Runner = {
								};
							};
							TabCount = 4;
						};
						SplitCount = 1;
						Tab1 = {
							OptionsSetName = "Default Options";
						};
						TabCount = 5;
					};
				},
				{
					LeftSlideOut = {
						Split0 = {
							Split0 = {
								NavCount = 1;
								NavGeometry0 = {
									Frame = "{{0, 0}, {685, 190}}";
									NavBarVisible = YES;
								};
							};
							SplitCount = 1;
							Tab0 = {
								Debugger = {
									Split0 = {
										SplitCount = 2;
									};
									SplitCount = 1;


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|

|
>
>
>
>
>








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172



































173
174
175
176
177
178
179
// !$*UTF8*$!
{
	005751AA02FB00930AC916F0 = {
		fRef = 005751AB02FB00930AC916F0;
		isa = PBXTextBookmark;
		name = "DefaultsDoc.rtf: 30";
		rLen = 32;
		rLoc = 2777;
		rType = 0;
		vrLen = 1334;
		vrLoc = 2136;
	};
	005751AB02FB00930AC916F0 = {
		isa = PBXFileReference;
		name = DefaultsDoc.rtf;
		path = "/Developer/Applications/Project Builder.app/Contents/Resources/DefaultsDoc.rtf";
		refType = 0;
	};
	00E2F845016E82EB0ACA28DC = {
		activeBuildStyle = 00E2F847016E82EB0ACA28DC;
		activeTarget = F50DC359017027D801DC9062;
		addToTargets = (
			00E2F84C016E8B780ACA28DC,
		);
		breakpoints = (
		);
		perUserDictionary = {
			PBXPerProjectTemplateStateSaveDate = 49920633;
			"PBXTemplateGeometry-F5314676015831810DCA290F" = {
				ContentSize = "{789, 551}";
				LeftSlideOut = {
					Collapsed = NO;
					Frame = "{{0, 23}, {789, 528}}";
					Split0 = {
						ActiveTab = 2;
						Collapsed = NO;
						Frame = "{{0, 0}, {789, 528}}";
						Split0 = {
							Frame = "{{0, 204}, {789, 324}}";
						};
						SplitCount = 1;
						Tab0 = {
							Debugger = {
								Collapsed = NO;
								Frame = "{{0, 0}, {952, 321}}";
								Split0 = {
									Frame = "{{0, 24}, {952, 297}}";
									Split0 = {
										Frame = "{{0, 0}, {468, 297}}";
									};
									Split1 = {
										DebugVariablesTableConfiguration = (
											Name,
											123,
											Value,
											85,
											Summary,
											241.123,
										);
										Frame = "{{477, 0}, {475, 297}}";
									};
									SplitCount = 2;
								};
								SplitCount = 1;
								Tab0 = {
									Frame = "{{0, 0}, {100, 50}}";
								};
								Tab1 = {
									Frame = "{{0, 0}, {100, 50}}";
								};
								TabCount = 2;
								TabsVisible = YES;
							};
							Frame = "{{0, 0}, {952, 321}}";
							LauncherConfigVersion = 7;
						};
						Tab1 = {
							Frame = "{{0, 0}, {781, 452}}";
							LauncherConfigVersion = 3;
							Runner = {
								Frame = "{{0, 0}, {781, 452}}";
							};
						};
						Tab2 = {
							BuildMessageFrame = "{{0, 0}, {791, 191}}";
							BuildTranscriptFrame = "{{0, 200}, {791, 0}}";
							Frame = "{{0, 0}, {789, 198}}";
						};
						Tab3 = {
							Frame = "{{0, 0}, {612, 295}}";
						};
						TabCount = 4;
						TabsVisible = NO;
					};
					SplitCount = 1;
					Tab0 = {
						Frame = "{{0, 0}, {300, 533}}";
						GroupTreeTableConfiguration = (
							TargetStatusColumn,
							18,
							MainColumn,
							267,
						);
					};
					Tab1 = {
						ClassesFrame = "{{0, 0}, {280, 398}}";
						ClassesTreeTableConfiguration = (
							PBXBookColumnIdentifier,
							20,
							PBXClassColumnIdentifier,
							237,
						);
						Frame = "{{0, 0}, {278, 659}}";
						MembersFrame = "{{0, 407}, {280, 252}}";
						MembersTreeTableConfiguration = (
							PBXBookColumnIdentifier,
							20,
							PBXMethodColumnIdentifier,
							236,
						);
					};
					Tab2 = {
						Frame = "{{0, 0}, {200, 100}}";
					};
					Tab3 = {
						Frame = "{{0, 0}, {200, 100}}";
						TargetTableConfiguration = (
							ActiveObject,
							16,
							ObjectNames,
							202.296,
						);
					};
					Tab4 = {
						BreakpointsTreeTableConfiguration = (
							breakpointColumn,
							197,
							enabledColumn,
							31,
						);
						Frame = "{{0, 0}, {250, 100}}";
					};
					TabCount = 5;
					TabsVisible = NO;
				};
				StatusViewVisible = YES;
				Template = F5314676015831810DCA290F;
				ToolbarVisible = YES;
				WindowLocation = "{7, 385}";
			};
			PBXWorkspaceContents = (
				{
					LeftSlideOut = {
						Split0 = {
							Split0 = {
								NavContent0 = {
									bookmark = 005751AA02FB00930AC916F0;
									history = (
										F5BFE56402F8B7A901DC9062,
										F5BFE56702F8B7A901DC9062,
										00F4D9CE02F9BA490AC916F0,
									);
									prevStack = (
										F5BFE56A02F8B7A901DC9062,
									);
								};
								NavCount = 1;
								NavGeometry0 = {
									Frame = "{{0, 0}, {571, 548}}";
									NavBarVisible = YES;
								};
							};



































							SplitCount = 1;
							Tab0 = {
								Debugger = {
									Split0 = {
										SplitCount = 2;
									};
									SplitCount = 1;
207
208
209
210
211
212
213
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
						};
						TabCount = 5;
						TabsVisible = YES;
					};
					StatusViewVisible = YES;
					Template = 64ABBB4501FA494900185B06;
					ToolbarVisible = YES;
					WindowLocation = "{134, 113}";
				},
				{
					ContentSize = "{685, 434}";
					LeftSlideOut = {
						Collapsed = NO;
						Frame = "{{0, 23}, {685, 411}}";
						Split0 = {
							ActiveTab = 2;
							Collapsed = NO;
							Frame = "{{0, 0}, {685, 411}}";
							Split0 = {
								Frame = "{{0, 221}, {685, 190}}";
							};
							SplitCount = 1;
							Tab0 = {
								Debugger = {
									Collapsed = NO;
									Frame = "{{0, 0}, {952, 321}}";
									Split0 = {
										Frame = "{{0, 24}, {952, 297}}";
										Split0 = {
											Frame = "{{0, 0}, {468, 297}}";
										};
										Split1 = {
											DebugVariablesTableConfiguration = (
												Name,
												126.803,
												Value,
												150.074,
												Summary,
												172.123,
											);
											Frame = "{{477, 0}, {475, 297}}";
										};
										SplitCount = 2;
									};
									SplitCount = 1;
									Tab0 = {
										Frame = "{{0, 0}, {100, 50}}";
									};
									Tab1 = {
										Frame = "{{0, 0}, {100, 50}}";
									};
									TabCount = 2;
									TabsVisible = YES;
								};
								Frame = "{{0, 0}, {952, 321}}";
								LauncherConfigVersion = 7;
							};
							Tab1 = {
								Frame = "{{0, 0}, {781, 452}}";
								LauncherConfigVersion = 3;
								Runner = {
									Frame = "{{0, 0}, {781, 452}}";
								};
							};
							Tab2 = {
								BuildMessageFrame = "{{0, 0}, {687, 29}}";
								BuildTranscriptFrame = "{{0, 38}, {687, 179}}";
								Frame = "{{0, 0}, {685, 215}}";
							};
							Tab3 = {
								Frame = "{{0, 0}, {612, 295}}";
							};
							TabCount = 4;
							TabsVisible = NO;
						};
						SplitCount = 1;
						Tab0 = {
							Frame = "{{0, 0}, {300, 533}}";
							GroupTreeTableConfiguration = (
								SCMStatusColumn,
								22,
								TargetStatusColumn,
								18,
								MainColumn,
								245,
							);
						};
						Tab1 = {
							ClassesFrame = "{{0, 0}, {280, 398}}";
							ClassesTreeTableConfiguration = (
								PBXBookColumnIdentifier,
								20,
								PBXClassColumnIdentifier,
								237,
							);
							Frame = "{{0, 0}, {278, 659}}";
							MembersFrame = "{{0, 407}, {280, 252}}";
							MembersTreeTableConfiguration = (
								PBXBookColumnIdentifier,
								20,
								PBXMethodColumnIdentifier,
								236,
							);
						};
						Tab2 = {
							Frame = "{{0, 0}, {200, 100}}";
						};
						Tab3 = {
							Frame = "{{0, 0}, {200, 100}}";
							TargetTableConfiguration = (
								ActiveObject,
								16,
								ObjectNames,
								202.296,
							);
						};
						Tab4 = {
							BreakpointsTreeTableConfiguration = (
								breakpointColumn,
								197,
								enabledColumn,
								31,
							);
							Frame = "{{0, 0}, {250, 100}}";
						};
						TabCount = 5;
						TabsVisible = NO;
					};
					StatusViewVisible = YES;
					Template = F5314676015831810DCA290F;
					ToolbarVisible = YES;
					WindowLocation = "{7, 250}";
				},
			);
			PBXWorkspaceStateSaveDate = 45284653;
		};
		perUserProjectItems = {


			F55BC4B702B2E09001DC9062 = F55BC4B702B2E09001DC9062;
			F5A8CC2B02B2FBA001DC9062 = F5A8CC2B02B2FBA001DC9062;

		};
		projectwideBuildSettings = {
			OBJROOT = "/Volumes/CodeBits/jingham/Tcl/Merge-Build";
			SYMROOT = "/Volumes/CodeBits/jingham/Tcl/Merge-Products";
		};
		wantsIndex = 1;
		wantsSCM = 1;
	};
	00E2F84B016E8A830ACA28DC = {
		activeExec = 0;
	};
	00E2F84C016E8B780ACA28DC = {
		activeExec = 0;
	};
	00E2F84E016E92110ACA28DC = {
		activeExec = 0;
	};
















	F50DC359017027D801DC9062 = {
		activeExec = 0;
	};
	F55BC4B702B2E09001DC9062 = {
		fRef = F55BC4B802B2E09101DC9062;
		isa = PBXTextBookmark;
		name = "tkWinInit.c: 1";
		rLen = 0;
		rLoc = 0;
		rType = 0;
		vrLen = 809;
		vrLoc = 0;
	};
	F55BC4B802B2E09101DC9062 = {

		isa = PBXFileReference;
		name = tkWinInit.c;
		path = "/Volumes/CodeBits/jingham/Tcl/Source-merge/tk/win/tkWinInit.c";


		refType = 0;


	};
	F5A8CC2B02B2FBA001DC9062 = {
		fRef = F5A8CC2C02B2FBA001DC9062;
		isa = PBXTextBookmark;
		name = "tkWinInit.c: 1";
		rLen = 0;
		rLoc = 0;
		rType = 0;
		vrLen = 809;
		vrLoc = 0;
	};
	F5A8CC2C02B2FBA001DC9062 = {
		isa = PBXFileReference;
		name = tkWinInit.c;
		path = "/Volumes/CodeBits/jingham/Tcl/Source-merge/tk/win/tkWinInit.c";
		refType = 0;
	};
}







|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

>
>
|
|
>


|
|













>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|
|

|



|
|

|
>
|
|
<
>
>
|
>
>

|
|

|
|
|

|
|

|

|
|



315
316
317
318
319
320
321
322
323






























324
































325

326





























































327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
						};
						TabCount = 5;
						TabsVisible = YES;
					};
					StatusViewVisible = YES;
					Template = 64ABBB4501FA494900185B06;
					ToolbarVisible = YES;
					WindowLocation = "{77, 330}";
				},






























			);
































			PBXWorkspaceStateSaveDate = 49920633;

		};





























































		perUserProjectItems = {
			005751AA02FB00930AC916F0 = 005751AA02FB00930AC916F0;
			00F4D9CE02F9BA490AC916F0 = 00F4D9CE02F9BA490AC916F0;
			F5BFE56402F8B7A901DC9062 = F5BFE56402F8B7A901DC9062;
			F5BFE56702F8B7A901DC9062 = F5BFE56702F8B7A901DC9062;
			F5BFE56A02F8B7A901DC9062 = F5BFE56A02F8B7A901DC9062;
		};
		projectwideBuildSettings = {
			OBJROOT = "/Volumes/TheCloset/jingham/tcl-tk/source/tcl-merge/Objects";
			SYMROOT = "/Volumes/TheCloset/jingham/tcl-tk/source/tcl-merge/Products";
		};
		wantsIndex = 1;
		wantsSCM = 1;
	};
	00E2F84B016E8A830ACA28DC = {
		activeExec = 0;
	};
	00E2F84C016E8B780ACA28DC = {
		activeExec = 0;
	};
	00E2F84E016E92110ACA28DC = {
		activeExec = 0;
	};
	00F4D9CE02F9BA490AC916F0 = {
		fRef = 00F4D9CF02F9BA4A0AC916F0;
		isa = PBXTextBookmark;
		name = "DefaultsDoc.rtf: 30";
		rLen = 32;
		rLoc = 2777;
		rType = 0;
		vrLen = 1334;
		vrLoc = 2136;
	};
	00F4D9CF02F9BA4A0AC916F0 = {
		isa = PBXFileReference;
		name = DefaultsDoc.rtf;
		path = "/Developer/Applications/Project Builder.app/Contents/Resources/DefaultsDoc.rtf";
		refType = 0;
	};
	F50DC359017027D801DC9062 = {
		activeExec = 0;
	};
	F5BFE56402F8B7A901DC9062 = {
		fRef = F5BFE56E02F8B7AA01DC9062;
		isa = PBXTextBookmark;
		name = "stat.h: 1";
		rLen = 0;
		rLoc = 0;
		rType = 0;
		vrLen = 1666;
		vrLoc = 3618;
	};
	F5BFE56702F8B7A901DC9062 = {
		fRef = F5F24F6E016ECAA401DC9062;
		isa = PBXTextBookmark;
		name = "tcl.h: 397";

		rLen = 6;
		rLoc = 11199;
		rType = 0;
		vrLen = 1293;
		vrLoc = 10644;
	};
	F5BFE56A02F8B7A901DC9062 = {
		fRef = F5F24F6E016ECAA401DC9062;
		isa = PBXTextBookmark;
		name = "tcl.h: 397";
		rLen = 6;
		rLoc = 11199;
		rType = 0;
		vrLen = 1293;
		vrLoc = 10644;
	};
	F5BFE56E02F8B7AA01DC9062 = {
		isa = PBXFileReference;
		name = stat.h;
		path = /usr/include/sys/stat.h;
		refType = 0;
	};
}
Changes to macosx/Tcl.pbproj/project.pbxproj.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
// !$*UTF8*$!
{
	archiveVersion = 1;
	classes = {
	};
	objectVersion = 38;
	objects = {
		00530A0D0173C8270ACA28DC = {
			buildActionMask = 2147483647;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);
			runOnlyForDeploymentPostprocessing = 0;
			shellPath = /bin/sh;
			shellScript = "cp \"${OBJROOT}/${PRODUCT_NAME}\" \"${SYMROOT}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}/Versions/${FRAMEWORK_VERSION}\"";

		};
		00530A0E0173CC960ACA28DC = {
			buildActionMask = 2147483647;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);
			runOnlyForDeploymentPostprocessing = 0;
			shellPath = /bin/sh;
			shellScript = "cp \"${OBJROOT}/tclConfig.sh\" \"${SYMROOT}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}/Versions/${FRAMEWORK_VERSION}/Headers\"";

		};
		00E2F845016E82EB0ACA28DC = {
			buildStyles = (
				00E2F847016E82EB0ACA28DC,
				00E2F848016E82EB0ACA28DC,
			);
			isa = PBXProject;








|







<

<
>


|







<

<
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

17

18
19
20
21
22
23
24
25
26
27
28

29

30
31
32
33
34
35
36
37
// !$*UTF8*$!
{
	archiveVersion = 1;
	classes = {
	};
	objectVersion = 38;
	objects = {
		00530A0D0173C8270ACA28DC = {
			buildActionMask = 12;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);

			shellPath = /bin/sh;

			shellScript = "# install to ${INSTALL_ROOT} with optional stripping\ncd ${TEMP_DIR}/..\nif test \"${INSTALL_STRIP}\" = \"YES\"; then\nexport INSTALL_PROGRAM='${INSTALL} ${INSTALL_STRIP_PROGRAM}'\nexport INSTALL_LIBRARY='${INSTALL} ${INSTALL_STRIP_LIBRARY}'\nelse\nexport INSTALL_PROGRAM='${INSTALL}'\nexport INSTALL_LIBRARY='${INSTALL}'\nfi\ngnumake install-binaries install-libraries TCL_LIBRARY=\"@TCL_IN_FRAMEWORK@\" INSTALL_ROOT=${INSTALL_ROOT} SCRIPT_INSTALL_DIR=${INSTALL_ROOT}${LIBDIR}/Resources/Scripts INSTALL_PROGRAM=\"${INSTALL_PROGRAM}\" INSTALL_LIBRARY=\"${INSTALL_LIBRARY}\"";
		};
		00530A0E0173CC960ACA28DC = {
			buildActionMask = 12;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);

			shellPath = /bin/sh;

			shellScript = "# fixup Framework structure\ncd ${INSTALL_ROOT}${LIBDIR}\nln -fs Versions/Current/Headers ../..\nmv -f tclConfig.sh Resources\nif test \"${INSTALL_STRIP}\" = \"NO\"; then\n\t# assume this is a Development build, keep copy of debug library\n\t# so that Deployment build can be installed alongside subsequently\n\tcp -f ${PRODUCT_NAME} ${PRODUCT_NAME}_debug\nfi";
		};
		00E2F845016E82EB0ACA28DC = {
			buildStyles = (
				00E2F847016E82EB0ACA28DC,
				00E2F848016E82EB0ACA28DC,
			);
			isa = PBXProject;
59
60
61
62
63
64
65

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
			isa = PBXGroup;
			refType = 4;
		};
		00E2F847016E82EB0ACA28DC = {
			buildRules = (
			);
			buildSettings = {

				COPY_PHASE_STRIP = NO;
				STRIP_BY_HAND = NO;
			};
			isa = PBXBuildStyle;
			name = Development;
		};
		00E2F848016E82EB0ACA28DC = {
			buildRules = (
			);
			buildSettings = {
				CFLAGS = "-Os";
				COPY_PHASE_STRIP = NO;
				STRIP_BY_HAND = YES;
			};
			isa = PBXBuildStyle;
			name = Deployment;
		};
		00E2F84A016E8A830ACA28DC = {
			children = (
				00E2F84D016E92110ACA28DC,
			);
			isa = PBXGroup;
			name = Products;
			refType = 4;
		};
		00E2F84B016E8A830ACA28DC = {
			buildArgumentsString = "$SRCROOT/../unix/configure --enable-threads=yes --enable-shared=yes --enable-symbols=no --enable-framework=yes --prefix=/Library/Frameworks";
			buildPhases = (
			);
			buildSettings = {
				DSTROOT = /usr/local/lib;
				OTHER_CFLAGS = "";
				OTHER_LDFLAGS = "";
				OTHER_REZFLAGS = "";

				PRODUCT_NAME = Configure;
				SECTORDER_FLAGS = "";
				WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas";
			};
			buildToolPath = /bin/sh;
			buildWorkingDirectory = $OBJROOT;
			dependencies = (
			);
			isa = PBXLegacyTarget;
			name = Configure;
			productName = Configure;
			settingsToExpand = 6;
			settingsToPassInEnvironment = 287;
			settingsToPassOnCommandLine = 280;
			shouldUseHeadermap = 0;
		};
		00E2F84C016E8B780ACA28DC = {
			buildArgumentsString = "Tcl libtclstub${FRAMEWORK_VERSION}.a CFLAGS=\"${CFLAGS}\" SHLIB_LD=\"${SHLIB_LD}\" TCL_LIBRARY=\"@TCL_IN_FRAMEWORK@\"";
			buildPhases = (
			);
			buildSettings = {
				CFLAGS = "-g";
				DSTROOT = /Library;
				FRAMEWORK_VERSION = 8.4;
				OTHER_CFLAGS = "";
				OTHER_LDFLAGS = "";
				OTHER_REZFLAGS = "";

				PRODUCT_NAME = Tcl;
				SECTORDER_FLAGS = "";
				SHLIB_LD = "cc -framework CoreFoundation -dynamiclib -seg1addr 0xb0000 -prebind -install_name /Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}/Tcl";
				WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas";
			};
			buildToolPath = /usr/bin/gnumake;
			buildWorkingDirectory = $OBJROOT;
			dependencies = (
			);
			isa = PBXLegacyTarget;
			name = Make;
			productName = Make;
			settingsToExpand = 6;
			settingsToPassInEnvironment = 287;







>
|
<








<
|
<













|



<
|
|
|
>

<
<


|











|



|
<

|
<
<
>

<
<
<


|







57
58
59
60
61
62
63
64
65

66
67
68
69
70
71
72
73

74

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91

92
93
94
95
96


97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115

116
117


118
119



120
121
122
123
124
125
126
127
128
129
			isa = PBXGroup;
			refType = 4;
		};
		00E2F847016E82EB0ACA28DC = {
			buildRules = (
			);
			buildSettings = {
				EXTRA_CONFIGURE_FLAGS = "--enable-symbols";
				INSTALL_STRIP = NO;

			};
			isa = PBXBuildStyle;
			name = Development;
		};
		00E2F848016E82EB0ACA28DC = {
			buildRules = (
			);
			buildSettings = {

				INSTALL_STRIP = YES;

			};
			isa = PBXBuildStyle;
			name = Deployment;
		};
		00E2F84A016E8A830ACA28DC = {
			children = (
				00E2F84D016E92110ACA28DC,
			);
			isa = PBXGroup;
			name = Products;
			refType = 4;
		};
		00E2F84B016E8A830ACA28DC = {
			buildArgumentsString = "-c \"${SRCROOT}/../unix/configure --prefix=/usr --mandir=/usr/share/man --libdir=${LIBDIR} --includedir=${LIBDIR}/Headers --enable-threads --enable-framework ${EXTRA_CONFIGURE_FLAGS};\\\nmkdir -p Tcl.framework; ln -fs ../Tcl Tcl.framework/Tcl\"";
			buildPhases = (
			);
			buildSettings = {

				EXTRA_CONFIGURE_FLAGS = "";
				FRAMEWORK_VERSION = 8.4;
				INSTALL_PATH = /Library/Frameworks;
				LIBDIR = "/Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}";
				PRODUCT_NAME = Configure;


			};
			buildToolPath = /bin/sh;
			buildWorkingDirectory = "${TEMP_DIR}/..";
			dependencies = (
			);
			isa = PBXLegacyTarget;
			name = Configure;
			productName = Configure;
			settingsToExpand = 6;
			settingsToPassInEnvironment = 287;
			settingsToPassOnCommandLine = 280;
			shouldUseHeadermap = 0;
		};
		00E2F84C016E8B780ACA28DC = {
			buildArgumentsString = "TCL_LIBRARY=\"@TCL_IN_FRAMEWORK@\" ${EXTRA_MAKE_FLAGS}";
			buildPhases = (
			);
			buildSettings = {
				EXTRA_MAKE_FLAGS = "";

				FRAMEWORK_VERSION = 8.4;
				INSTALL_PATH = /Library/Frameworks;


				LIBDIR = "/Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}";
				PRODUCT_NAME = Tcl;



			};
			buildToolPath = /usr/bin/gnumake;
			buildWorkingDirectory = "${TEMP_DIR}/..";
			dependencies = (
			);
			isa = PBXLegacyTarget;
			name = Make;
			productName = Make;
			settingsToExpand = 6;
			settingsToPassInEnvironment = 287;
148
149
150
151
152
153
154

155
156
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
		};
		00E2F84E016E92110ACA28DC = {
			buildPhases = (
				F50DC36A01703B7301DC9062,
				F50DC367017033D701DC9062,
				F50DC3680170344801DC9062,
				00E2F84F016E92110ACA28DC,

				00530A0D0173C8270ACA28DC,
				00530A0E0173CC960ACA28DC,
				F5C1D51801B8730B01DC9062,
				F5F2500E016ED0E001DC9062,
				F56570CE0172204201DC9062,
				F59AE5E3017AC67A01DC9062,
			);
			buildSettings = {
				DYLIB_COMPATIBILITY_VERSION = 8.4;
				DYLIB_CURRENT_VERSION = 8.4;
				FRAMEWORK_VERSION = 8.4;
				INSTALL_PATH = /Library/Frameworks;
				LIBRARY_SEARCH_PATHS = "$(OBJROOT)/Tcl.build";
				OPTIMIZATION_CFLAGS = "-O0";
				OTHER_CFLAGS = "";
				OTHER_LDFLAGS = "";
				OTHER_LIBTOOL_FLAGS = "";
				OTHER_REZFLAGS = "";
				PRINCIPAL_CLASS = "";
				PRODUCT_NAME = Tcl;
				SECTORDER_FLAGS = "";
				WARNING_CFLAGS = "-Wmost -Wno-four-char-constants -Wno-unknown-pragmas";
				WRAPPER_EXTENSION = framework;
			};
			dependencies = (
			);
			isa = PBXFrameworkTarget;
			name = TclLibrary;
			productInstallPath = /Library/Frameworks;







>


<
<
<



|
|


|
<
<
<
<
<
<

<
<







137
138
139
140
141
142
143
144
145
146



147
148
149
150
151
152
153
154






155


156
157
158
159
160
161
162
		};
		00E2F84E016E92110ACA28DC = {
			buildPhases = (
				F50DC36A01703B7301DC9062,
				F50DC367017033D701DC9062,
				F50DC3680170344801DC9062,
				00E2F84F016E92110ACA28DC,
				F5BE9BBF02FB5974016F146B,
				00530A0D0173C8270ACA28DC,
				00530A0E0173CC960ACA28DC,



				F59AE5E3017AC67A01DC9062,
			);
			buildSettings = {
				DSTROOT = "${TEMP_DIR}";
				EXTRA_MAKE_INSTALL_FLAGS = "";
				FRAMEWORK_VERSION = 8.4;
				INSTALL_PATH = /Library/Frameworks;
				LIBDIR = "/Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}";






				PRODUCT_NAME = Tcl;


				WRAPPER_EXTENSION = framework;
			};
			dependencies = (
			);
			isa = PBXFrameworkTarget;
			name = TclLibrary;
			productInstallPath = /Library/Frameworks;
196
197
198
199
200
201
202
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
	<key>CFBundleIconFile</key>
	<string></string>
	<key>CFBundleIdentifier</key>
	<string>com.tcltk.tcllibrary</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleName</key>
	<string>Tcl Library 8.4a4</string>
	<key>CFBundlePackageType</key>
	<string>FMWK</string>
	<key>CFBundleShortVersionString</key>
	<string>libtcl8.4a4</string>
	<key>CFBundleSignature</key>
	<string>Tcl </string>
	<key>CFBundleVersion</key>
	<string>8.4a4</string>
</dict>
</plist>
";
			shouldUseHeadermap = 0;
		};
		00E2F84F016E92110ACA28DC = {
			buildActionMask = 2147483647;
			files = (
				F5F24F79016ECAA401DC9062,
				F5F24F7A016ECAA401DC9062,
				F5F24F7B016ECAA401DC9062,
				F5F24F7C016ECAA401DC9062,
				F5F24F7D016ECAA401DC9062,
				F5F24F7E016ECAA401DC9062,
				F5F24F7F016ECAA401DC9062,
				F5F24F80016ECAA401DC9062,
				F5F24F81016ECAA401DC9062,
				F5F24F82016ECAA401DC9062,
				F5F24F83016ECAA401DC9062,
				F5F24F84016ECAA401DC9062,
				F5F24F85016ECAA401DC9062,
				F5F24F86016ECAA401DC9062,
			);
			isa = PBXHeadersBuildPhase;
			runOnlyForDeploymentPostprocessing = 0;
		};
		00E2F854016E922C0ACA28DC = {
			children = (
				F5F24F87016ECAFC01DC9062,
				F5F24F88016ECAFC01DC9062,
				F5F24F89016ECAFC01DC9062,
				F5F24F8A016ECAFC01DC9062,







|



|



|








<
<
<
<
<
<
<
<
<
<
<
<
<
<


<







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198














199
200

201
202
203
204
205
206
207
	<key>CFBundleIconFile</key>
	<string></string>
	<key>CFBundleIdentifier</key>
	<string>com.tcltk.tcllibrary</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleName</key>
	<string>Tcl Library 8.4b2</string>
	<key>CFBundlePackageType</key>
	<string>FMWK</string>
	<key>CFBundleShortVersionString</key>
	<string>libtcl8.4b2</string>
	<key>CFBundleSignature</key>
	<string>Tcl </string>
	<key>CFBundleVersion</key>
	<string>8.4b2</string>
</dict>
</plist>
";
			shouldUseHeadermap = 0;
		};
		00E2F84F016E92110ACA28DC = {
			buildActionMask = 2147483647;
			files = (














			);
			isa = PBXHeadersBuildPhase;

		};
		00E2F854016E922C0ACA28DC = {
			children = (
				F5F24F87016ECAFC01DC9062,
				F5F24F88016ECAFC01DC9062,
				F5F24F89016ECAFC01DC9062,
				F5F24F8A016ECAFC01DC9062,
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
			name = Headers;
			refType = 4;
		};
		00E2F85C016E92B00ACA28DC = {
			children = (
				F5F24FD8016ECC0F01DC9062,
				F5F24FD9016ECC0F01DC9062,
				F5F24FDA016ECC0F01DC9062,
				F5F24FDB016ECC0F01DC9062,
				F5F24FDC016ECC0F01DC9062,
				F5F24FDD016ECC0F01DC9062,
				F5F24FDE016ECC0F01DC9062,
				F5F24FDF016ECC0F01DC9062,
				F5F24FE0016ECC0F01DC9062,
				F5F24FE1016ECC0F01DC9062,







<







356
357
358
359
360
361
362

363
364
365
366
367
368
369
			name = Headers;
			refType = 4;
		};
		00E2F85C016E92B00ACA28DC = {
			children = (
				F5F24FD8016ECC0F01DC9062,
				F5F24FD9016ECC0F01DC9062,

				F5F24FDB016ECC0F01DC9062,
				F5F24FDC016ECC0F01DC9062,
				F5F24FDD016ECC0F01DC9062,
				F5F24FDE016ECC0F01DC9062,
				F5F24FDF016ECC0F01DC9062,
				F5F24FE0016ECC0F01DC9062,
				F5F24FE1016ECC0F01DC9062,
459
460
461
462
463
464
465
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
			target = 00E2F84E016E92110ACA28DC;
		};
		F50DC367017033D701DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			isa = PBXFrameworksBuildPhase;
			runOnlyForDeploymentPostprocessing = 0;
		};
		F50DC3680170344801DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			isa = PBXResourcesBuildPhase;
			runOnlyForDeploymentPostprocessing = 0;
		};
		F50DC36A01703B7301DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			isa = PBXSourcesBuildPhase;
			runOnlyForDeploymentPostprocessing = 0;
		};
		F56570CE0172204201DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);
			runOnlyForDeploymentPostprocessing = 0;
			shellPath = /bin/sh;
			shellScript = "rm -rf \"${SYMROOT}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}/Versions/A\"";

		};
		F59AE5E3017AC67A01DC9062 = {





			buildActionMask = 2147483647;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);
			runOnlyForDeploymentPostprocessing = 0;
			shellPath = /bin/sh;
			shellScript = "if test \"${STRIP_BY_HAND}\" = \"YES\"; then \n    strip -x \"${SYMROOT}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}/Versions/${FRAMEWORK_VERSION}/${PRODUCT_NAME}\"\nfi";
		};
		F5A1836F018242A501DC9062 = {
			isa = PBXFileReference;
			path = tclMacOSXBundle.c;
			refType = 4;
		};
		F5C1D51801B8730B01DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);
			runOnlyForDeploymentPostprocessing = 0;
			shellPath = /bin/sh;
			shellScript = "cp \"${OBJROOT}/libtclstub${FRAMEWORK_VERSION}.a\" \"${SYMROOT}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}/Versions/${FRAMEWORK_VERSION}\"";

		};
		F5C88655017D604601DC9062 = {
			children = (
				F5C88656017D604601DC9062,
				F5C88657017D60C901DC9062,
				F5C88658017D60C901DC9062,
			);
			isa = PBXGroup;
			name = "Header Tools";
			refType = 4;
		};
		F5C88656017D604601DC9062 = {
			isa = PBXFileReference;
			name = genStubs.tcl;
			path = /Volumes/CodeBits/jingham/Tcl/source/tcl/tools/genStubs.tcl;
			refType = 0;
		};
		F5C88657017D60C901DC9062 = {
			isa = PBXFileReference;
			name = tcl.decls;
			path = /Volumes/CodeBits/jingham/Tcl/source/tcl/generic/tcl.decls;
			refType = 0;
		};
		F5C88658017D60C901DC9062 = {
			isa = PBXFileReference;
			name = tclInt.decls;
			path = /Volumes/CodeBits/jingham/Tcl/source/tcl/generic/tclInt.decls;
			refType = 0;
		};
		F5F24F6B016ECAA401DC9062 = {
			isa = PBXFileReference;
			name = regcustom.h;
			path = ../generic/regcustom.h;
			refType = 2;
		};







<






<






<

|
|







<

<
>

|
>
>
>
>
>








<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
>














|
|




|
|




|
|







422
423
424
425
426
427
428

429
430
431
432
433
434

435
436
437
438
439
440

441
442
443
444
445
446
447
448
449
450

451

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467

468



















469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
			target = 00E2F84E016E92110ACA28DC;
		};
		F50DC367017033D701DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			isa = PBXFrameworksBuildPhase;

		};
		F50DC3680170344801DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			isa = PBXResourcesBuildPhase;

		};
		F50DC36A01703B7301DC9062 = {
			buildActionMask = 2147483647;
			files = (
			);
			isa = PBXSourcesBuildPhase;

		};
		F59AE5E3017AC67A01DC9062 = {
			buildActionMask = 8;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);

			shellPath = /bin/sh;

			shellScript = "# build html documentation\ncd ${TEMP_DIR}/..\nmake html DISTDIR=${INSTALL_ROOT}${LIBDIR}/Resources/English.lproj/Documentation/Reference\ncd ${INSTALL_ROOT}${LIBDIR}/Resources/English.lproj/Documentation/Reference\nln -fs contents.htm html/index.html\nrm -f  ${PRODUCT_NAME}; ln -fs html ${PRODUCT_NAME}";
		};
		F5A1836F018242A501DC9062 = {
			isa = PBXFileReference;
			path = tclMacOSXBundle.c;
			refType = 4;
		};
		F5BE9BBF02FB5974016F146B = {
			buildActionMask = 2147483647;
			files = (
			);
			generatedFileNames = (
			);
			isa = PBXShellScriptBuildPhase;
			neededFileNames = (
			);

			shellPath = /bin/sh;



















			shellScript = "# symolic link hackery to enable 'make install INSTALL_ROOT=${TEMP_DIR}'\n# to build Tcl.framework and tclsh in ${SYMROOT}\ncd ${TEMP_DIR}\nmkdir -p Library; rm -f Library/Frameworks; ln -fs ${SYMROOT} Library/Frameworks\nmkdir -p usr; rm -f usr/bin; ln -fs ${SYMROOT} usr/bin";
		};
		F5C88655017D604601DC9062 = {
			children = (
				F5C88656017D604601DC9062,
				F5C88657017D60C901DC9062,
				F5C88658017D60C901DC9062,
			);
			isa = PBXGroup;
			name = "Header Tools";
			refType = 4;
		};
		F5C88656017D604601DC9062 = {
			isa = PBXFileReference;
			name = genStubs.tcl;
			path = ../tools/genStubs.tcl;
			refType = 2;
		};
		F5C88657017D60C901DC9062 = {
			isa = PBXFileReference;
			name = tcl.decls;
			path = ../generic/tcl.decls;
			refType = 2;
		};
		F5C88658017D60C901DC9062 = {
			isa = PBXFileReference;
			name = tclInt.decls;
			path = ../generic/tclInt.decls;
			refType = 2;
		};
		F5F24F6B016ECAA401DC9062 = {
			isa = PBXFileReference;
			name = regcustom.h;
			path = ../generic/regcustom.h;
			refType = 2;
		};
631
632
633
634
635
636
637
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
		};
		F5F24F78016ECAA401DC9062 = {
			isa = PBXFileReference;
			name = tclRegexp.h;
			path = ../generic/tclRegexp.h;
			refType = 2;
		};
		F5F24F79016ECAA401DC9062 = {
			fileRef = F5F24F6B016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F7A016ECAA401DC9062 = {
			fileRef = F5F24F6C016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F7B016ECAA401DC9062 = {
			fileRef = F5F24F6D016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F7C016ECAA401DC9062 = {
			fileRef = F5F24F6E016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
				ATTRIBUTES = (
					Public,
				);
			};
		};
		F5F24F7D016ECAA401DC9062 = {
			fileRef = F5F24F6F016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F7E016ECAA401DC9062 = {
			fileRef = F5F24F70016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
				ATTRIBUTES = (
					Public,
				);
			};
		};
		F5F24F7F016ECAA401DC9062 = {
			fileRef = F5F24F71016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F80016ECAA401DC9062 = {
			fileRef = F5F24F72016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
				ATTRIBUTES = (
					Private,
				);
			};
		};
		F5F24F81016ECAA401DC9062 = {
			fileRef = F5F24F73016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
				ATTRIBUTES = (
					Private,
				);
			};
		};
		F5F24F82016ECAA401DC9062 = {
			fileRef = F5F24F74016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
				ATTRIBUTES = (
					Private,
				);
			};
		};
		F5F24F83016ECAA401DC9062 = {
			fileRef = F5F24F75016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F84016ECAA401DC9062 = {
			fileRef = F5F24F76016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F85016ECAA401DC9062 = {
			fileRef = F5F24F77016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
				ATTRIBUTES = (
					Private,
				);
			};
		};
		F5F24F86016ECAA401DC9062 = {
			fileRef = F5F24F78016ECAA401DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F24F87016ECAFC01DC9062 = {
			isa = PBXFileReference;
			name = regc_color.c;
			path = ../generic/regc_color.c;
			refType = 2;
		};
		F5F24F88016ECAFC01DC9062 = {







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







576
577
578
579
580
581
582






































































































583
584
585
586
587
588
589
		};
		F5F24F78016ECAA401DC9062 = {
			isa = PBXFileReference;
			name = tclRegexp.h;
			path = ../generic/tclRegexp.h;
			refType = 2;
		};






































































































		F5F24F87016ECAFC01DC9062 = {
			isa = PBXFileReference;
			name = regc_color.c;
			path = ../generic/regc_color.c;
			refType = 2;
		};
		F5F24F88016ECAFC01DC9062 = {
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
		};
		F5F24FD9016ECC0F01DC9062 = {
			isa = PBXFileReference;
			name = tclLoadDyld.c;
			path = ../unix/tclLoadDyld.c;
			refType = 2;
		};
		F5F24FDA016ECC0F01DC9062 = {
			isa = PBXFileReference;
			name = tclMtherr.c;
			path = ../unix/tclMtherr.c;
			refType = 2;
		};
		F5F24FDB016ECC0F01DC9062 = {
			isa = PBXFileReference;
			name = tclUnixChan.c;
			path = ../unix/tclUnixChan.c;
			refType = 2;
		};
		F5F24FDC016ECC0F01DC9062 = {







<
<
<
<
<
<







1062
1063
1064
1065
1066
1067
1068






1069
1070
1071
1072
1073
1074
1075
		};
		F5F24FD9016ECC0F01DC9062 = {
			isa = PBXFileReference;
			name = tclLoadDyld.c;
			path = ../unix/tclLoadDyld.c;
			refType = 2;
		};






		F5F24FDB016ECC0F01DC9062 = {
			isa = PBXFileReference;
			name = tclUnixChan.c;
			path = ../unix/tclUnixChan.c;
			refType = 2;
		};
		F5F24FDC016ECC0F01DC9062 = {
1307
1308
1309
1310
1311
1312
1313
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
			path = ../unix/tclXtTest.c;
			refType = 2;
		};
		F5F24FEE016ED0DF01DC9062 = {
			children = (
				F5F24FEF016ED0DF01DC9062,
				F5F24FF0016ED0DF01DC9062,
				F5F24FF1016ED0DF01DC9062,
				F5F24FF2016ED0DF01DC9062,
				F5F24FF3016ED0DF01DC9062,
				F5F24FF4016ED0DF01DC9062,
				F5F24FF5016ED0DF01DC9062,
				F5F24FF6016ED0DF01DC9062,
				F5F24FF7016ED0DF01DC9062,
				F5F24FF8016ED0DF01DC9062,
				F5F24FF9016ED0DF01DC9062,
				F5F24FFA016ED0DF01DC9062,
				F5F24FFB016ED0DF01DC9062,
				F5F24FFC016ED0DF01DC9062,
				F5F24FFD016ED0DF01DC9062,
				F5F24FFE016ED0DF01DC9062,
				F5F24FFF016ED0DF01DC9062,
				F5F25000016ED0DF01DC9062,
				F5F25001016ED0DF01DC9062,
				F5F25002016ED0DF01DC9062,
				F5F25003016ED0DF01DC9062,
				F5F25004016ED0DF01DC9062,
				F5F25005016ED0DF01DC9062,
				F5F25006016ED0DF01DC9062,
				F5F25007016ED0DF01DC9062,
				F5F25008016ED0DF01DC9062,
				F5F25009016ED0DF01DC9062,
				F5F2500A016ED0DF01DC9062,
			);
			isa = PBXGroup;
			name = Scripts;
			refType = 4;
		};
		F5F24FEF016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = auto.tcl;
			path = ../library/auto.tcl;
			refType = 2;
		};
		F5F24FF0016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = dde;
			path = ../library/dde;
			refType = 2;
		};
		F5F24FF1016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = dde1.0;
			path = ../library/dde1.0;
			refType = 2;
		};
		F5F24FF2016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = dde1.1;
			path = ../library/dde1.1;
			refType = 2;
		};
		F5F24FF3016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = encoding;
			path = ../library/encoding;
			refType = 2;
		};







<
<




<
<
<



<

<
<



<

<


<



















<
<
<
<
<
<
<
<
<
<
<
<
<
<







1144
1145
1146
1147
1148
1149
1150


1151
1152
1153
1154



1155
1156
1157

1158


1159
1160
1161

1162

1163
1164

1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183














1184
1185
1186
1187
1188
1189
1190
			path = ../unix/tclXtTest.c;
			refType = 2;
		};
		F5F24FEE016ED0DF01DC9062 = {
			children = (
				F5F24FEF016ED0DF01DC9062,
				F5F24FF0016ED0DF01DC9062,


				F5F24FF3016ED0DF01DC9062,
				F5F24FF4016ED0DF01DC9062,
				F5F24FF5016ED0DF01DC9062,
				F5F24FF6016ED0DF01DC9062,



				F5F24FFA016ED0DF01DC9062,
				F5F24FFB016ED0DF01DC9062,
				F5F24FFC016ED0DF01DC9062,

				F5F24FFE016ED0DF01DC9062,


				F5F25001016ED0DF01DC9062,
				F5F25002016ED0DF01DC9062,
				F5F25003016ED0DF01DC9062,

				F5F25005016ED0DF01DC9062,

				F5F25007016ED0DF01DC9062,
				F5F25008016ED0DF01DC9062,

				F5F2500A016ED0DF01DC9062,
			);
			isa = PBXGroup;
			name = Scripts;
			refType = 4;
		};
		F5F24FEF016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = auto.tcl;
			path = ../library/auto.tcl;
			refType = 2;
		};
		F5F24FF0016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = dde;
			path = ../library/dde;
			refType = 2;
		};














		F5F24FF3016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = encoding;
			path = ../library/encoding;
			refType = 2;
		};
1392
1393
1394
1395
1396
1397
1398
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
		F5F24FF6016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = http1.0;
			path = ../library/http1.0;
			refType = 2;
		};
		F5F24FF7016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = http2.0;
			path = ../library/http2.0;
			refType = 2;
		};
		F5F24FF8016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = http2.1;
			path = ../library/http2.1;
			refType = 2;
		};
		F5F24FF9016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = http2.3;
			path = ../library/http2.3;
			refType = 2;
		};
		F5F24FFA016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = init.tcl;
			path = ../library/init.tcl;
			refType = 2;
		};
		F5F24FFB016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = ldAout.tcl;
			path = ../library/ldAout.tcl;
			refType = 2;
		};
		F5F24FFC016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = msgcat;
			path = ../library/msgcat;
			refType = 2;
		};
		F5F24FFD016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = msgcat1.0;
			path = ../library/msgcat1.0;
			refType = 2;
		};
		F5F24FFE016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = opt;
			path = ../library/opt;
			refType = 2;
		};
		F5F24FFF016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = opt0.1;
			path = ../library/opt0.1;
			refType = 2;
		};
		F5F25000016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = opt0.4;
			path = ../library/opt0.4;
			refType = 2;
		};
		F5F25001016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = package.tcl;
			path = ../library/package.tcl;
			refType = 2;
		};
		F5F25002016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = parray.tcl;
			path = ../library/parray.tcl;
			refType = 2;
		};
		F5F25003016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = reg;
			path = ../library/reg;
			refType = 2;
		};
		F5F25004016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = reg1.0;
			path = ../library/reg1.0;
			refType = 2;
		};
		F5F25005016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = safe.tcl;
			path = ../library/safe.tcl;
			refType = 2;
		};
		F5F25006016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = struct1.0;
			path = ../library/struct1.0;
			refType = 2;
		};
		F5F25007016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = tclIndex;
			path = ../library/tclIndex;
			refType = 2;
		};
		F5F25008016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = tcltest;
			path = ../library/tcltest;
			refType = 2;
		};
		F5F25009016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = tcltest1.0;
			path = ../library/tcltest1.0;
			refType = 2;
		};
		F5F2500A016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = word.tcl;
			path = ../library/word.tcl;
			refType = 2;
		};
		F5F2500E016ED0E001DC9062 = {
			buildActionMask = 2147483647;
			dstPath = "../../$(FRAMEWORK_VERSION)/Resources/Scripts";
			dstSubfolderSpec = 7;
			files = (
				F5F2500F016ED0E001DC9062,
				F5F25010016ED0E001DC9062,
				F5F25013016ED0E001DC9062,
				F5F25014016ED0E001DC9062,
				F5F25015016ED0E001DC9062,
				F5F2501A016ED0E001DC9062,
				F5F2501B016ED0E001DC9062,
				F5F2501C016ED0E001DC9062,
				F5F2501E016ED0E001DC9062,
				F5F25021016ED0E001DC9062,
				F5F25022016ED0E001DC9062,
				F5F25023016ED0E001DC9062,
				F5F25025016ED0E001DC9062,
				F5F25027016ED0E001DC9062,
				F5F25028016ED0E001DC9062,
				F5F2502A016ED0E001DC9062,
			);
			isa = PBXCopyFilesBuildPhase;
			runOnlyForDeploymentPostprocessing = 0;
		};
		F5F2500F016ED0E001DC9062 = {
			fileRef = F5F24FEF016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25010016ED0E001DC9062 = {
			fileRef = F5F24FF0016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25013016ED0E001DC9062 = {
			fileRef = F5F24FF3016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25014016ED0E001DC9062 = {
			fileRef = F5F24FF4016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25015016ED0E001DC9062 = {
			fileRef = F5F24FF5016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F2501A016ED0E001DC9062 = {
			fileRef = F5F24FFA016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F2501B016ED0E001DC9062 = {
			fileRef = F5F24FFB016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F2501C016ED0E001DC9062 = {
			fileRef = F5F24FFC016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F2501E016ED0E001DC9062 = {
			fileRef = F5F24FFE016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25021016ED0E001DC9062 = {
			fileRef = F5F25001016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25022016ED0E001DC9062 = {
			fileRef = F5F25002016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25023016ED0E001DC9062 = {
			fileRef = F5F25003016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25025016ED0E001DC9062 = {
			fileRef = F5F25005016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25027016ED0E001DC9062 = {
			fileRef = F5F25007016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F25028016ED0E001DC9062 = {
			fileRef = F5F25008016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
		F5F2502A016ED0E001DC9062 = {
			fileRef = F5F2500A016ED0DF01DC9062;
			isa = PBXBuildFile;
			settings = {
			};
		};
	};
	rootObject = 00E2F845016E82EB0ACA28DC;
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



















<
<
<
<
<
<
<







<
<
<
<
<
<
<
<
<
<
<
<
<
<



















<
<
<
<
<
<
<






<
<
<
<
<
<
<













<
<
<
<
<
<
<






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



1204
1205
1206
1207
1208
1209
1210





















1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229







1230
1231
1232
1233
1234
1235
1236














1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255







1256
1257
1258
1259
1260
1261







1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274







1275
1276
1277
1278
1279
1280

























































































































1281
1282
1283
		F5F24FF6016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = http1.0;
			path = ../library/http1.0;
			refType = 2;
		};





















		F5F24FFA016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = init.tcl;
			path = ../library/init.tcl;
			refType = 2;
		};
		F5F24FFB016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = ldAout.tcl;
			path = ../library/ldAout.tcl;
			refType = 2;
		};
		F5F24FFC016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = msgcat;
			path = ../library/msgcat;
			refType = 2;
		};







		F5F24FFE016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = opt;
			path = ../library/opt;
			refType = 2;
		};














		F5F25001016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = package.tcl;
			path = ../library/package.tcl;
			refType = 2;
		};
		F5F25002016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = parray.tcl;
			path = ../library/parray.tcl;
			refType = 2;
		};
		F5F25003016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = reg;
			path = ../library/reg;
			refType = 2;
		};







		F5F25005016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = safe.tcl;
			path = ../library/safe.tcl;
			refType = 2;
		};







		F5F25007016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = tclIndex;
			path = ../library/tclIndex;
			refType = 2;
		};
		F5F25008016ED0DF01DC9062 = {
			includeInIndex = 0;
			isa = PBXFolderReference;
			name = tcltest;
			path = ../library/tcltest;
			refType = 2;
		};







		F5F2500A016ED0DF01DC9062 = {
			isa = PBXFileReference;
			name = word.tcl;
			path = ../library/word.tcl;
			refType = 2;
		};

























































































































	};
	rootObject = 00E2F845016E82EB0ACA28DC;
}
Changes to macosx/tclMacOSXBundle.c.
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 *	libraryVariableName may be set, and the resource file opened.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
        char *bundleName,
        int hasResourceFile,       
        int maxPathLen,
        char *libraryPath)
{
    CFBundleRef bundleRef;
    CFStringRef bundleNameRef;
    







|







73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
 *	libraryVariableName may be set, and the resource file opened.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
        CONST char *bundleName,
        int hasResourceFile,       
        int maxPathLen,
        char *libraryPath)
{
    CFBundleRef bundleRef;
    CFStringRef bundleNameRef;
    
Changes to tests/README.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23



24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.8 1999/08/31 21:49:27 jenn Exp $

Contents:
---------

    1. Introduction
    2. Incompatibilities with prior Tcl versions

1. Introduction:
----------------

This directory contains a set of validation tests for the Tcl commands
and C Library procedures for Tcl.  Each of the files whose name ends
in ".test" is intended to fully exercise the functions in the C source
file that corresponds to the file prefix.  The C functions and/or Tcl
commands tested by a given file are listed in the first line of the
file.

You can run the tests in three ways:

    (a) type "make test" in ../unix; this will run all of the tests.




    (b) type "tcltest <testFile> ?<option> <value>?
	Command line options include:

	-help                display usage information

	-verbose <level>     set the level of verbosity to a substring
			     of "bps".  See the "Test output" section
			     of the tcltest man page for an
			     explanation of this option. 

	-match <matchList>   only run tests that match one or more of
			     the glob patterns in <matchList>

	-skip <skipList>     do not run tests that match one or more
			     of the glob patterns in <skipList>

	-file <globPatternList>  
		             only source test files that match one or
		             more of the glob patterns in
		             <globPatternList> (relative to the
		             "tests" directory).  This option only
		             applies when you run the test suite with
		             the "all.tcl" file.

	-notfile <globPatternList>  
	                     do not source test files that match one
	                     or more of the patterns in
	                     <globPatternList> (relative to the
	                     "tests" directory).  This option only
	                     applies when you run the test suite with
	                     the "all.tcl" file.

	-constraints <list>  tests with any constraints in <list> will
			     not be skipped.  Not that elements of
			     <list> must exactly match the existing
			     constraints.

        -limitconstraints <bool>
                             If 1, limit test runs to those tests that
                             match the constraints listed using the
                             -constraints flag.  Use of this flag
                             requires use of the -constraints flag.
                             The default value is 0.

        -tmpdir <dirname>    put temporary files created by
                             ::tcltest::makeFile and
                             ::tcltest::makeDirectory in the named
                             directory.  The default location is
                             ::tcltest::workingDirectory.

        -preservecore <level>
                             check for core files.  If level is 0,
                             check for core files only when
                             cleanupTests is called from an all.tcl
                             file.  If 1, also check at the end of
                             every test command.  If 2, also save core
                             files in ::tcltest::temporaryDirectory.
                             The default level is 0.
 
    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  To use the options in
	interactive mode, you can set their corresponding tcltest
	namespace variables after loading the tcltest package.
	For example, some of the tcltest variables are:
		  ::tcltest::match
		  ::tcltest::skip
		  ::tcltest::testConstraints(nonPortable)
		  ::tcltest::testConstraints(knownBug)
		  ::tcltest::testConstraints(userInteractive)


Please see the tcltest man page for more information regarding how to
write and run tests.

Please note that the all.tcl file will source your new test file if
the filename matches the tests/*.test pattern (as it should).  The
names of test files that contain regression (or glass-box) tests
should correspond to the Tcl or C code file that they are testing.
For example, the test file for the C file "tclCmdAH.c" is
"cmdAH.test".  Test files that contain black-box tests may not
correspond to any Tcl or C code file so they should match the pattern
"*_bb.test". 

Be sure your new test file can be run from any working directory.

Be sure no temporary files are left behind by your test file.



Be sure your tests can run cross-platform in both a build environment
as well as an installation environment.  If your test file contains
tests that should not be run in one or more of those cases, please use
the constraints mechanism to skip those tests.

2. Incompatibilities with prior Tcl versions:

---------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig are now
   renamed to use the new "tcltest" namespace.

   old name   new name
   --------   --------
   VERBOSE    ::tcltest::verbose
   TESTS      ::tcltest::match
   testConfig ::tcltest::testConstraints


2) VERBOSE values are no longer numeric.  


3) When you run "make test", the working dir for the test suite is now
   the one from which you called "make test", rather than the "tests"
   directory.  This change allows for both unix and windows test
   suites to be run simultaneously without interference with each
   other or with existing files.  All tests must now run independently
   of their working directory.

4) The "all" and "visual" files are now called "all.tcl" and
   "visual_bb.test".

5) The "defs" file no longer exists.

6) Instead of creating a doAllTests file in the tests directory, to
   run all nonPortable tests, just use the "-constraints nonPortable"
   command line flag.  If you are running interactively, you can set
   the ::tcltest::testConstraints(nonPortable) variable to 1 (after
   loading the tcltest package).


|



















|
>
>
>


<

<
|
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<



|
<
<
<
<
<
|
<
>
















>
>






|
>
|

|
<
|
<
<
<
<
|
>

|
>








|
<

|



|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

29

30


31

32

















































33
34
35
36





37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

68




69
70
71
72
73
74
75
76
77
78
79
80
81
82

83
84
85
86
87
88
89
90
README -- Tcl test suite design document.

RCS: @(#) $Id: README,v 1.8.18.1 2002/08/20 20:25:27 das Exp $

Contents:
---------

    1. Introduction
    2. Incompatibilities with prior Tcl versions

1. Introduction:
----------------

This directory contains a set of validation tests for the Tcl commands
and C Library procedures for Tcl.  Each of the files whose name ends
in ".test" is intended to fully exercise the functions in the C source
file that corresponds to the file prefix.  The C functions and/or Tcl
commands tested by a given file are listed in the first line of the
file.

You can run the tests in three ways:

    (a) type "make test" in ../unix; this will create the tcltest
	executable and run all of the tests.  At least "make tcltest"
	must be run to create the tcltest executable for the other
	options.

    (b) type "tcltest <testFile> ?<option> <value>?



	where the options and values are the configuration options


	of the tcltest package.

 

















































    (c) start up tcltest in this directory, then "source" the test
        file (for example, type "source parse.test").  To run all
	of the tests, type "source all.tcl".  To use the options in
	interactive mode, you can set them with the tcltest::configure





	command.  Set constraints with the tcltest::testConstraints

	command.

Please see the tcltest man page for more information regarding how to
write and run tests.

Please note that the all.tcl file will source your new test file if
the filename matches the tests/*.test pattern (as it should).  The
names of test files that contain regression (or glass-box) tests
should correspond to the Tcl or C code file that they are testing.
For example, the test file for the C file "tclCmdAH.c" is
"cmdAH.test".  Test files that contain black-box tests may not
correspond to any Tcl or C code file so they should match the pattern
"*_bb.test". 

Be sure your new test file can be run from any working directory.

Be sure no temporary files are left behind by your test file.
Use [tcltest::makeFile], [tcltest::removeFile], and [tcltest::cleanupTests]
properly to be sure of this.

Be sure your tests can run cross-platform in both a build environment
as well as an installation environment.  If your test file contains
tests that should not be run in one or more of those cases, please use
the constraints mechanism to skip those tests.

2. Incompatibilities of package tcltest 2.1 with 
   testing machinery of very old versions of Tcl:
------------------------------------------------

1) Global variables such as VERBOSE, TESTS, and testConfig of the

   old machinery correspond to the [configure -verbose], 




   [configure -match], and [testConstraint] commands of tcltest 2.1,
   respectively.

2) VERBOSE values were longer numeric.  [configure -verbose] values
   are lists of keywords.

3) When you run "make test", the working dir for the test suite is now
   the one from which you called "make test", rather than the "tests"
   directory.  This change allows for both unix and windows test
   suites to be run simultaneously without interference with each
   other or with existing files.  All tests must now run independently
   of their working directory.

4) The "all" file is now called "all.tcl"


5) The "defs" and "defs.tcl" files no longer exist.

6) Instead of creating a doAllTests file in the tests directory, to
   run all nonPortable tests, just use the "-constraints nonPortable"
   command line flag.  If you are running interactively, you can run
   [tcltest::testConstraint nonPortable 1] (after loading the tcltest
   package).
Deleted tests/autoMkindex.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
# Test file for:
#   auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading
# facility.  Things are much more complicated with namespaces and classes.
# The "auto_mkindex" facility can no longer be built on top of a simple
# regular expression parser.  It must recognize constructs like this:
#
#   namespace eval foo {
#       proc test {x y} { ... }
#       namespace eval bar {
#           proc another {args} { ... }
#       }
#   }
#
# Note that procedures and itcl class definitions can be nested inside
# of namespaces.
#
# Copyright (c) 1993-1998  Lucent Technologies, Inc.

# This shouldn't cause any problems
namespace import -force blt::*

# Should be able to handle "proc" definitions, even if they are
# preceded by white space.

proc normal {x y} {return [expr $x+$y]}
  proc indented {x y} {return [expr $x+$y]}

#
# Should be able to handle proc declarations within namespaces,
# even if they have explicit namespace paths.
#
namespace eval buried {
    proc inside {args} {return "inside: $args"}

    namespace export pub_*
    proc pub_one {args} {return "one: $args"}
    proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}

namespace eval buried {
    namespace eval under {
        proc neath {args} {return "neath: $args"}
    }
    namespace eval ::buried {
        proc relative {args} {return "relative: $args"}
        proc ::top {args} {return "top: $args"}
        proc ::buried::explicit {args} {return "explicit: $args"}
    }
}

# With proper hooks, we should be able to support other commands
# that create procedures

proc buried::myproc {name body args} {
    ::proc $name $body $args
}
namespace eval ::buried {
    proc mycmd1 args {return "mycmd"}
    myproc mycmd2 args {return "mycmd"}
}
::buried::myproc mycmd3 args {return "another"}

proc {buried::my proc} {name body args} {
    ::proc $name $body $args
}
namespace eval ::buried {
    proc mycmd4 args {return "mycmd"}
    {my proc} mycmd5 args {return "mycmd"}
}
{::buried::my proc} mycmd6 args {return "another"}

# A correctly functioning [auto_import] won't choke when a child
# namespace [namespace import]s from its parent.
#
namespace eval ::parent::child {
    namespace import ::parent::*
}
proc ::parent::child::test {} {}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































Changes to tests/autoMkindex.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
# Commands covered:  auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating
# the autoloading index.
#
# Copyright (c) 1998  Lucent Technologies, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: autoMkindex.test,v 1.12 2001/05/03 22:38:20 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}




















# temporarily copy the autoMkindex.tcl file from testsDirectory to


# temporaryDirectory 


set origMkindexFile [file join $::tcltest::testsDirectory autoMkindex.tcl]


set newMkindexFile [file join $::tcltest::temporaryDirectory autoMkindex.tcl]






if {![catch {file copy $origMkindexFile $newMkindexFile}]} {





    set removeAutoMkindex 1





































}





# Save initial state of auto_mkindex_parser

auto_load auto_mkindex
if {[info exist auto_mkindex_parser::initCommands]} {
    set saveCommands $auto_mkindex_parser::initCommands
}
proc AutoMkindexTestReset {} {
    global saveCommands
    if {[info exist saveCommands]} {
	set auto_mkindex_parser::initCommands $saveCommands
    } elseif {[info exist auto_mkindex_parser::initCommands]} {
	unset auto_mkindex_parser::initCommands
    }
}

set result ""

set origDir [pwd]
cd $::tcltest::testsDirectory

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
} {0}

test autoMkindex-1.2 {build tclIndex based on a test file} {











|


|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
>
>
|
>
>
|
>
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>



















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
# Commands covered:  auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating
# the autoloading index.
#
# Copyright (c) 1998  Lucent Technologies, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: autoMkindex.test,v 1.12.12.1 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

makeFile {# Test file for:
#   auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading
# facility.  Things are much more complicated with namespaces and classes.
# The "auto_mkindex" facility can no longer be built on top of a simple
# regular expression parser.  It must recognize constructs like this:
#
#   namespace eval foo {
#       proc test {x y} { ... }
#       namespace eval bar {
#           proc another {args} { ... }
#       }
#   }
#
# Note that procedures and itcl class definitions can be nested inside
# of namespaces.
#
# Copyright (c) 1993-1998  Lucent Technologies, Inc.

# This shouldn't cause any problems
namespace import -force blt::*

# Should be able to handle "proc" definitions, even if they are
# preceded by white space.

proc normal {x y} {return [expr $x+$y]}
  proc indented {x y} {return [expr $x+$y]}

#
# Should be able to handle proc declarations within namespaces,
# even if they have explicit namespace paths.
#
namespace eval buried {
    proc inside {args} {return "inside: $args"}

    namespace export pub_*
    proc pub_one {args} {return "one: $args"}
    proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}

namespace eval buried {
    namespace eval under {
        proc neath {args} {return "neath: $args"}
    }
    namespace eval ::buried {
        proc relative {args} {return "relative: $args"}
        proc ::top {args} {return "top: $args"}
        proc ::buried::explicit {args} {return "explicit: $args"}
    }
}

# With proper hooks, we should be able to support other commands
# that create procedures

proc buried::myproc {name body args} {
    ::proc $name $body $args
}
namespace eval ::buried {
    proc mycmd1 args {return "mycmd"}
    myproc mycmd2 args {return "mycmd"}
}
::buried::myproc mycmd3 args {return "another"}

proc {buried::my proc} {name body args} {
    ::proc $name $body $args
}
namespace eval ::buried {
    proc mycmd4 args {return "mycmd"}
    {my proc} mycmd5 args {return "mycmd"}
}
{::buried::my proc} mycmd6 args {return "another"}

# A correctly functioning [auto_import] won't choke when a child
# namespace [namespace import]s from its parent.
#
namespace eval ::parent::child {
    namespace import ::parent::*
}
proc ::parent::child::test {} {}

} autoMkindex.tcl


# Save initial state of auto_mkindex_parser

auto_load auto_mkindex
if {[info exist auto_mkindex_parser::initCommands]} {
    set saveCommands $auto_mkindex_parser::initCommands
}
proc AutoMkindexTestReset {} {
    global saveCommands
    if {[info exist saveCommands]} {
	set auto_mkindex_parser::initCommands $saveCommands
    } elseif {[info exist auto_mkindex_parser::initCommands]} {
	unset auto_mkindex_parser::initCommands
    }
}

set result ""

set origDir [pwd]
cd $::tcltest::temporaryDirectory

test autoMkindex-1.1 {remove any existing tclIndex file} {
    file delete tclIndex
    file exists tclIndex
} {0}

test autoMkindex-1.2 {build tclIndex based on a test file} {
171
172
173
174
175
176
177































178
179
180
181
182
183
184
185
186
187
188











189
190
191
192
193
194
195
196
197
198
199
200







201
202
203
204
205
206
207
208
209
210
211
212
213



214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
	    return [lindex $list $ix]
	} else {
	    return {}
	}
    }
    list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*]
} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"
































test autoMkindex-4.1 {platform indenpendant source commands} {
    file delete tclIndex
    auto_mkindex . pkg/samename.tcl
    set f [open tclIndex r]
    set dat [split [string trim [read $f]] "\n"]
    set len [llength $dat]
    set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]]
    close $f
    set result
} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}












test autoMkindex-5.1 {escape magic tcl chars in general code} {
    file delete tclIndex
    set result {}
    if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } {
	set f [open tclIndex r]
	set dat [split [string trim [read $f]] "\n"]
	set result [lindex $dat end]
	close $f
    }
    set result
} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}







test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
    file delete tclIndex
    set res {}
    if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } {
	# Make a slave interp to test the autoloading
	set c [interp create]
	$c eval {lappend auto_path [pwd]}
	set res [$c eval {catch {{[magic mojo proc]}}}]
	interp delete $c
    }
    set res
} 0




# Clean up.

unset result
AutoMkindexTestReset
if {[info exist saveCommands]} {
    unset saveCommands
}
rename AutoMkindexTestReset ""

if {[info exists removeAutoMkindex]} {
    catch {file delete $newMkindexFile}
}
if {[file exists tclIndex]} {
    file delete -force tclIndex
}

cd $origDir

::tcltest::cleanupTests







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











>
>
>
>
>
>
>
>
>
>
>












>
>
>
>
>
>
>













>
>
>









|
<
<







248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352


353
354
355
356
357
358
359
	    return [lindex $list $ix]
	} else {
	    return {}
	}
    }
    list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*]
} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"


makeDirectory pkg
makeFile {
package provide football 1.0
    
namespace eval ::pro:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}
namespace eval ::college:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}

proc ::pro::team {} {
    puts "go packers!"
    return true
}

proc ::college::team {} {
    puts "go badgers!"
    return true
}

} [file join pkg samename.tcl]


test autoMkindex-4.1 {platform indenpendant source commands} {
    file delete tclIndex
    auto_mkindex . pkg/samename.tcl
    set f [open tclIndex r]
    set dat [split [string trim [read $f]] "\n"]
    set len [llength $dat]
    set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]]
    close $f
    set result
} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}

removeFile [file join pkg samename.tcl]

makeFile {
set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo"
set bracket1 "this contains an unescaped bracket [NoSuchProc]"
set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]"
proc testProc {} {}
} [file join pkg magicchar.tcl]

test autoMkindex-5.1 {escape magic tcl chars in general code} {
    file delete tclIndex
    set result {}
    if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } {
	set f [open tclIndex r]
	set dat [split [string trim [read $f]] "\n"]
	set result [lindex $dat end]
	close $f
    }
    set result
} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}

removeFile [file join pkg magicchar.tcl]

makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]

test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
    file delete tclIndex
    set res {}
    if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } {
	# Make a slave interp to test the autoloading
	set c [interp create]
	$c eval {lappend auto_path [pwd]}
	set res [$c eval {catch {{[magic mojo proc]}}}]
	interp delete $c
    }
    set res
} 0

removeFile [file join pkg magicchar2.tcl]
removeDirectory pkg

# Clean up.

unset result
AutoMkindexTestReset
if {[info exist saveCommands]} {
    unset saveCommands
}
rename AutoMkindexTestReset ""

removeFile autoMkindex.tcl


if {[file exists tclIndex]} {
    file delete -force tclIndex
}

cd $origDir

::tcltest::cleanupTests
Changes to tests/basic.test.
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.12.4.2 2002/06/10 05:33:15 wolfsuit Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(testcmdtoken) \
	[llength [info commands testcmdtoken]]
set ::tcltest::testConstraints(testcmdtrace) \
	[llength [info commands testcmdtrace]]
set ::tcltest::testConstraints(testcreatecommand) \
	[llength [info commands testcreatecommand]]
set ::tcltest::testConstraints(exec) \
	[llength [info commands exec]]

# This variable needs to be changed when the major or minor version number for
# Tcl changes.
set tclvers 8.4

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}







|


<
|
|
|
<
<
|
<
|
<
|
<
|







11
12
13
14
15
16
17
18
19
20

21
22
23


24

25

26

27
28
29
30
31
32
33
34
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.12.4.3 2002/08/20 20:25:27 das Exp $
#


package require tcltest 2
namespace import -force ::tcltest::*



testConstraint testcmdtoken [llength [info commands testcmdtoken]]

testConstraint testcmdtrace [llength [info commands testcmdtrace]]

testConstraint testcreatecommand [llength [info commands testcreatecommand]]

testConstraint exec [llength [info commands exec]]

# This variable needs to be changed when the major or minor version number for
# Tcl changes.
set tclvers 8.4

catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
422
423
424
425
426
427
428

429
430
431
432
433
434
435
436
437
438
439
440
441
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
    # If object isn't preserved, errorInfo would be set to
    # "foo\n    while executing\n\"garbage bytes\"" because the object's
    # string would have been freed, leaving garbage bytes for the error
    # message.

    proc bgerror {args} {set ::x $::errorInfo}

    set f [open test1 w]
    fileevent $f writable "fileevent $f writable {}; error foo"
    set x {}
    vwait x
    close $f
    file delete test1
    rename bgerror {}
    set x
} "foo\n    while executing\n\"error foo\""

test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}








>
|




|







416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
    # If object isn't preserved, errorInfo would be set to
    # "foo\n    while executing\n\"garbage bytes\"" because the object's
    # string would have been freed, leaving garbage bytes for the error
    # message.

    proc bgerror {args} {set ::x $::errorInfo}
    set fName [makeFile {} test1]
    set f [open $fName w]
    fileevent $f writable "fileevent $f writable {}; error foo"
    set x {}
    vwait x
    close $f
    removeFile test1
    rename bgerror {}
    set x
} "foo\n    while executing\n\"error foo\""

test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573

test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}

test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}

test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    catch {close $f}
    set res [catch {
	set f [open |[list [info nameofexecutable]] w+]
	fconfigure $f -buffering line
	puts $f {fconfigure stdout -buffering line}
	puts $f continue
	puts $f {puts $errorInfo}
	puts $f {puts DONE}
	set newMsg {}
	set msg {}







|


|







551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568

test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}

test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}

test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
    catch {close $f}
    set res [catch {
	set f [open |[list [interpreter]] w+]
	fconfigure $f -buffering line
	puts $f {fconfigure stdout -buffering line}
	puts $f continue
	puts $f {puts $errorInfo}
	puts $f {puts DONE}
	set newMsg {}
	set msg {}
582
583
584
585
586
587
588
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
    while executing
"continue
"
DONE
}}

test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    makeFile {
	puts hello
	break
    } BREAKtest
    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
    removeFile BREAKtest

    set res
} {1 {hello
invoked "break" outside of a loop
    while executing
"break"
    (file "BREAKtest" line 3)}}    

test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    makeFile {
	interp alias {} patch {} info patchlevel
	patch
	break
    } BREAKtest
    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
    removeFile BREAKtest

    set res
} {1 {invoked "break" outside of a loop
    while executing
"break"
    (file "BREAKtest" line 4)}}    

test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    makeFile {
	foo [set a 1] [break]
    } BREAKtest
    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
    removeFile BREAKtest

    set res
} {1 {invoked "break" outside of a loop
    while executing
"break"
    invoked from within
"foo [set a 1] [break]"
    (file "BREAKtest" line 2)}}

test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    makeFile {
	return -code return
    } BREAKtest
    set res [list [catch {exec [info nameofexecutable] BREAKtest} msg] $msg]
    removeFile BREAKtest

    set res
} {1 {command returned bad code: 2
    while executing
"return -code return"
    (file "BREAKtest" line 2)}}









|


|
|

>








|



|
|

>







|

|
|

>









|

|
|

>







577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
    while executing
"continue
"
DONE
}}

test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	puts hello
	break
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
    set res
} {1 {hello
invoked "break" outside of a loop
    while executing
"break"
    (file "BREAKtest" line 3)}}    

test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	interp alias {} patch {} info patchlevel
	patch
	break
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
    set res
} {1 {invoked "break" outside of a loop
    while executing
"break"
    (file "BREAKtest" line 4)}}    

test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	foo [set a 1] [break]
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
    set res
} {1 {invoked "break" outside of a loop
    while executing
"break"
    invoked from within
"foo [set a 1] [break]"
    (file "BREAKtest" line 2)}}

test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
    set fName [makeFile {
	return -code return
    } BREAKtest]
    set res [list [catch {exec [interpreter] $fName} msg] $msg]
    removeFile BREAKtest
    regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
    set res
} {1 {command returned bad code: 2
    while executing
"return -code return"
    (file "BREAKtest" line 2)}}


Changes to tests/clock.test.
1
2
3
4
5
6
7
8
9
10
11
12
13


14
15
16
17
18
19
20
# Commands covered:  clock
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.test,v 1.16.8.2 2002/06/10 05:33:15 wolfsuit Exp $



if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test clock-1.1 {clock tests} {












|
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# Commands covered:  clock
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.test,v 1.16.8.3 2002/08/20 20:25:27 das Exp $

set env(LC_TIME) POSIX

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test clock-1.1 {clock tests} {
108
109
110
111
112
113
114








115
116
117
118
119
120
121
} {1 {bad switch "-bad": must be -format or -gmt}}
test clock-3.11 {clock format tests} {
    clock format 123 -format "x"
} x
test clock-3.12 {clock format tests} {
    clock format 123 -format ""
} ""









# clock scan
test clock-4.1 {clock scan tests} {
    list [catch {clock scan} msg] $msg
} {1 {wrong # args: should be "clock scan dateString ?-base clockValue? ?-gmt boolean?"}}
test clock-4.2 {clock scan tests} {
    list [catch {clock scan "bad-string"} msg] $msg







>
>
>
>
>
>
>
>







110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
} {1 {bad switch "-bad": must be -format or -gmt}}
test clock-3.11 {clock format tests} {
    clock format 123 -format "x"
} x
test clock-3.12 {clock format tests} {
    clock format 123 -format ""
} ""
test clock-3.13 {clock format with non-ASCII character in the format string} {
    set oldenc [encoding system] 
    encoding system iso8859-1
    set res [clock format 0 -format \u00c4]
    encoding system $oldenc
    unset oldenc
    set res
} "\u00c4"

# clock scan
test clock-4.1 {clock scan tests} {
    list [catch {clock scan} msg] $msg
} {1 {wrong # args: should be "clock scan dateString ?-base clockValue? ?-gmt boolean?"}}
test clock-4.2 {clock scan tests} {
    list [catch {clock scan "bad-string"} msg] $msg
Changes to tests/cmdAH.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# The file tests the tclCmdAH.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1998 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdAH.test,v 1.15.6.2 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]

global env
set cmdAHwd [pwd]












|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# The file tests the tclCmdAH.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1998 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdAH.test,v 1.15.6.3 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]

global env
set cmdAHwd [pwd]
38
39
40
41
42
43
44

45
46
47
48
49
50
51
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
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
    list [catch {catch foo bar baz} msg] $msg
} {1 {wrong # args: should be "catch command ?varName?"}}

test cmdAH-2.1 {Tcl_CdObjCmd} {
    list [catch {cd foo bar} msg] $msg
} {1 {wrong # args: should be "cd ?dirName?"}}

test cmdAH-2.2 {Tcl_CdObjCmd} {
    file delete -force foo
    file mkdir foo
    cd foo
    set result [file tail [pwd]]
    cd ..
    file delete foo
    set result
} foo
test cmdAH-2.3 {Tcl_CdObjCmd} {
    global env
    set oldpwd [pwd]
    set temp $env(HOME)
    set env(HOME) $oldpwd
    file delete -force foo
    file mkdir foo
    cd foo
    cd ~
    set result [string equal [pwd] $oldpwd]
    file delete foo
    set env(HOME) $temp
    set result
} 1
test cmdAH-2.4 {Tcl_CdObjCmd} {
    global env
    set oldpwd [pwd]
    set temp $env(HOME)
    set env(HOME) $oldpwd
    file delete -force foo
    file mkdir foo
    cd foo
    cd
    set result [string equal [pwd] $oldpwd]
    file delete foo
    set env(HOME) $temp
    set result
} 1
test cmdAH-2.5 {Tcl_CdObjCmd} {
    list [catch {cd ~~} msg] $msg
} {1 {user "~" doesn't exist}}
test cmdAH-2.6 {Tcl_CdObjCmd} {







>

|
|
|


|







|
|
|


|








|
|
|


|







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
    list [catch {catch foo bar baz} msg] $msg
} {1 {wrong # args: should be "catch command ?varName?"}}

test cmdAH-2.1 {Tcl_CdObjCmd} {
    list [catch {cd foo bar} msg] $msg
} {1 {wrong # args: should be "cd ?dirName?"}}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} {
    file delete -force $foodir
    file mkdir $foodir
    cd $foodir
    set result [file tail [pwd]]
    cd ..
    file delete $foodir
    set result
} foo
test cmdAH-2.3 {Tcl_CdObjCmd} {
    global env
    set oldpwd [pwd]
    set temp $env(HOME)
    set env(HOME) $oldpwd
    file delete -force $foodir
    file mkdir $foodir
    cd $foodir
    cd ~
    set result [string equal [pwd] $oldpwd]
    file delete $foodir
    set env(HOME) $temp
    set result
} 1
test cmdAH-2.4 {Tcl_CdObjCmd} {
    global env
    set oldpwd [pwd]
    set temp $env(HOME)
    set env(HOME) $oldpwd
    file delete -force $foodir
    file mkdir $foodir
    cd $foodir
    cd
    set result [string equal [pwd] $oldpwd]
    file delete $foodir
    set env(HOME) $temp
    set result
} 1
test cmdAH-2.5 {Tcl_CdObjCmd} {
    list [catch {cd ~~} msg] $msg
} {1 {user "~" doesn't exist}}
test cmdAH-2.6 {Tcl_CdObjCmd} {
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
} identity

test cmdAH-5.1 {Tcl_FileObjCmd} {
    list [catch file msg] $msg
} {1 {wrong # args: should be "file option ?arg ...?"}}
test cmdAH-5.2 {Tcl_FileObjCmd} {
    list [catch {file x} msg] $msg
} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-5.3 {Tcl_FileObjCmd} {
    list [catch {file exists} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
test cmdAH-5.4 {Tcl_FileObjCmd} {
    list [catch {file exists ""} msg] $msg
} {0 0}








|







165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
} identity

test cmdAH-5.1 {Tcl_FileObjCmd} {
    list [catch file msg] $msg
} {1 {wrong # args: should be "file option ?arg ...?"}}
test cmdAH-5.2 {Tcl_FileObjCmd} {
    list [catch {file x} msg] $msg
} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-5.3 {Tcl_FileObjCmd} {
    list [catch {file exists} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
test cmdAH-5.4 {Tcl_FileObjCmd} {
    list [catch {file exists ""} msg] $msg
} {0 0}

193
194
195
196
197
198
199








200
201
202
203

204
205
206



207
208
209
210
211
212
213
214
    set volumeList [file volumes]
    catch [list glob -nocomplain [lindex $volumeList 0]*]
} {0}
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} {
    set volumeList [string tolower [file volumes]]
    list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}]
} {0 1 0}









# attributes

test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {

    catch {file delete -force foo.file}
    close [open foo.file w]
    list [catch {file attributes foo.file}] [file delete -force foo.file]



} {0 {}}

# dirname

if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test Tcl_FileObjCmd etc."
} else {







>
>
>
>
>
>
>
>




>
|
|
|
>
>
>
|







194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
    set volumeList [file volumes]
    catch [list glob -nocomplain [lindex $volumeList 0]*]
} {0}
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} {
    set volumeList [string tolower [file volumes]]
    list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}]
} {0 1 0}

test cmdAH-6.5 {cd} {unixOnly nonPortable} {
    set dir [pwd]
    cd /
    set res [pwd]
    cd $dir
    set res
} {/}

# attributes

test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {
    set foofile [makeFile abcde foo.file]
    catch {file delete -force $foofile}
    close [open $foofile w]
    set res [catch {file attributes $foofile}]
    # We used [makeFile] so we undo with [removeFile]
    removeFile $foofile
    set res
} {0}

# dirname

if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
1000
1001
1002
1003
1004
1005
1006
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
} {1 {user "_bad_user" doesn't exist}}

testsetplatform $platform
}

# readable

makeFile abcde gorp.file
makeDirectory dir.file

if {[info commands testchmod] == {}} {
    puts "This application hasn't been compiled with the \"testchmod\""
    puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} {
    list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 0444 gorp.file
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} {
    file readable gorp.file
} 1
testchmod 0333 gorp.file
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} {
    file reada gorp.file
} 0

# writable

test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} {
    list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
testchmod 0555 gorp.file
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} {
    file writable gorp.file
} 0
testchmod 0222 gorp.file
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} {
    file writable gorp.file
} 1
}

# executable

file delete -force dir.file gorp.file
file mkdir dir.file

makeFile abcde gorp.file

test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} {
    list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} {
    file executable gorp.file
} 0
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {
    # Only on unix will setting the execute bit on a regular file
    # cause that file to be executable.   
    
    testchmod 0775 gorp.file
    file exe gorp.file
} 1

test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} {
    # On mac, the only executable files are of type APPL.

    set x [file exe gorp.file]    
    file attrib gorp.file -type APPL
    lappend x [file exe gorp.file]
} {0 1}
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} {
    # On pc, must be a .exe, .com, etc.
    
    set x [file exe gorp.file]
    makeFile foo gorp.exe
    lappend x [file exe gorp.exe]
    file delete gorp.exe
    set x
} {0 1}
test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} {
    # Directories are always executable.
    
    file exe dir.file
} 1

file delete -force dir.file  
file delete gorp.file

file delete link.file

# exists

test cmdAH-19.1 {Tcl_FileObjCmd: exists} {
    list [catch {file exists a b} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0
test cmdAH-19.3 {Tcl_FileObjCmd: exists} {
    file exists [file join dir.file gorp.file]
} 0
catch {
    makeFile abcde gorp.file
    makeDirectory dir.file
    makeFile 12345 [file join dir.file gorp.file]
}
test cmdAH-19.4 {Tcl_FileObjCmd: exists} {
    file exists gorp.file
} 1
test cmdAH-19.5 {Tcl_FileObjCmd: exists} {
    file exists [file join dir.file gorp.file]
} 1

# nativename
if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test Tcl_FileObjCmd etc."
} else {







|
|








|

|

|

|







|

|

|

|





|
|
>
|





|





|
|





|
|
|




|
|
|
|





|


|
|
>
|






|

|


|
|
|


|


|







1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
} {1 {user "_bad_user" doesn't exist}}

testsetplatform $platform
}

# readable

set gorpfile [makeFile abcde gorp.file]
set dirfile [makeDirectory dir.file]

if {[info commands testchmod] == {}} {
    puts "This application hasn't been compiled with the \"testchmod\""
    puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} {
    list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 0444 $gorpfile
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} {
    file readable $gorpfile
} 1
testchmod 0333 $gorpfile
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} {
    file reada $gorpfile
} 0

# writable

test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} {
    list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
testchmod 0555 $gorpfile
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} {
    file writable $gorpfile
} 0
testchmod 0222 $gorpfile
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} {
    file writable $gorpfile
} 1
}

# executable

removeFile $gorpfile
removeDirectory $dirfile
set dirfile [makeDirectory dir.file]
set gorpfile [makeFile abcde gorp.file]

test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} {
    list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} {
    file executable $gorpfile
} 0
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {
    # Only on unix will setting the execute bit on a regular file
    # cause that file to be executable.   
    
    testchmod 0775 $gorpfile
    file exe $gorpfile
} 1

test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} {
    # On mac, the only executable files are of type APPL.

    set x [file exe $gorpfile]    
    file attrib $gorpfile -type APPL
    lappend x [file exe $gorpfile]
} {0 1}
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} {
    # On pc, must be a .exe, .com, etc.
    
    set x [file exe $gorpfile]
    set gorpexe [makeFile foo gorp.exe]
    lappend x [file exe $gorpexe]
    removeFile $gorpexe
    set x
} {0 1}
test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} {
    # Directories are always executable.
    
    file exe $dirfile
} 1

removeDirectory $dirfile
removeFile $gorpfile
set linkfile [file join [temporaryDirectory] link.file]
file delete $linkfile

# exists

test cmdAH-19.1 {Tcl_FileObjCmd: exists} {
    list [catch {file exists a b} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0
test cmdAH-19.3 {Tcl_FileObjCmd: exists} {
    file exists [file join [temporaryDirectory] dir.file gorp.file]
} 0
catch {
    set gorpfile [makeFile abcde gorp.file]
    set dirfile [makeDirectory dir.file]
    set subgorp [makeFile 12345 [file join $dirfile gorp.file]]
}
test cmdAH-19.4 {Tcl_FileObjCmd: exists} {
    file exists $gorpfile
} 1
test cmdAH-19.5 {Tcl_FileObjCmd: exists} {
    file exists $subgorp
} 1

# nativename
if {[info commands testsetplatform] == {}} {
    puts "This application hasn't been compiled with the \"testsetplatform\""
    puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
1133
1134
1135
1136
1137
1138
1139
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
} 1

# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system:  some
# NFS file systems won't do the stuff below correctly.

test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {
    removeFile /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    makeDirectory /tmp/tcl.foo.dir
    makeFile 12345 /tmp/tcl.foo.dir/file
    exec chmod 000 /tmp/tcl.foo.dir

    set result [file exists /tmp/tcl.foo.dir/file]

    exec chmod 775 /tmp/tcl.foo.dir
    removeFile /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    set result
} 0

# Stat related commands

catch {testsetplatform $platform}
file delete gorp.file
makeFile "Test string" gorp.file
catch {exec chmod 765 gorp.file}

# atime

set file [makeFile "data" touch.me]

test cmdAH-20.1 {Tcl_FileObjCmd: atime} {
    list [catch {file atime a b c} msg] $msg
} {1 {wrong # args: should be "file atime name ?time?"}}
test cmdAH-20.2 {Tcl_FileObjCmd: atime} {
    catch {unset stat}
    file stat gorp.file stat
    list [expr {[file mtime gorp.file] == $stat(mtime)}] \
	    [expr {[file atime gorp.file] == $stat(atime)}]
} {1 1}
test cmdAH-20.3 {Tcl_FileObjCmd: atime} {
    string tolower [list [catch {file atime _bogus_} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-20.4 {Tcl_FileObjCmd: atime} {
    list [catch {file atime $file notint} msg] $msg







|
|


|



|








|
|
|










|
|
|







1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
} 1

# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system:  some
# NFS file systems won't do the stuff below correctly.

test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {
    file delete -force /tmp/tcl.foo.dir/file
    file delete -force /tmp/tcl.foo.dir
    makeDirectory /tmp/tcl.foo.dir
    makeFile 12345 /tmp/tcl.foo.dir/file
    file attributes /tmp/tcl.foo.dir -permissions 0000

    set result [file exists /tmp/tcl.foo.dir/file]

    file attributes /tmp/tcl.foo.dir -permissions 0775
    removeFile /tmp/tcl.foo.dir/file
    removeDirectory /tmp/tcl.foo.dir
    set result
} 0

# Stat related commands

catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}

# atime

set file [makeFile "data" touch.me]

test cmdAH-20.1 {Tcl_FileObjCmd: atime} {
    list [catch {file atime a b c} msg] $msg
} {1 {wrong # args: should be "file atime name ?time?"}}
test cmdAH-20.2 {Tcl_FileObjCmd: atime} {
    catch {unset stat}
    file stat $gorpfile stat
    list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
	    [expr {[file atime $gorpfile] == $stat(atime)}]
} {1 1}
test cmdAH-20.3 {Tcl_FileObjCmd: atime} {
    string tolower [list [catch {file atime _bogus_} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-20.4 {Tcl_FileObjCmd: atime} {
    list [catch {file atime $file notint} msg] $msg
1193
1194
1195
1196
1197
1198
1199

1200
1201
1202
1203
1204
1205
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
    set atime [file atime $file]
    after 1100; # pause a sec to notice change in atime
    set newatime [clock seconds]
    set modatime [file atime $file $newatime]
    expr {$newatime == $modatime ? 1 : "$newatime != $modatime"}
} 1


# isdirectory

test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} {
    list [catch {file isdirectory a b} msg] $msg
} {1 {wrong # args: should be "file isdirectory name"}}
test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {
    file isdirectory gorp.file
} 0
test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} {
    file isd dir.file
} 1

# isfile

test cmdAH-22.1 {Tcl_FileObjCmd: isfile} {
    list [catch {file isfile a b} msg] $msg
} {1 {wrong # args: should be "file isfile name"}}
test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1
test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0

# lstat and readlink:  don't run these tests everywhere, since not all
# sites will have symbolic links

catch {exec ln -s gorp.file link.file}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} {
    list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.2 {Tcl_FileObjCmd: lstat} {
    list [catch {file lstat a b c} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
    catch {unset stat}
    file lstat link.file stat
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
    catch {unset stat}
    file lstat link.file stat
    list $stat(nlink) [expr $stat(mode)&0777] $stat(type)
} {1 511 link}
test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {
    string tolower [list [catch {file lstat _bogus_ stat} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} {
    catch {unset x}
    set x 44
    list [catch {file lstat gorp.file x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
catch {unset stat}

# mkdir



test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force a}
    file mkdir a
    set res [file isdirectory a]
    file delete a
    set res
} {1}
test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force a}
    file mkdir a/b
    set res [file isdirectory a/b]
    file delete -force a
    set res
} {1}
test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force a}
    file mkdir a/b/c
    set res [file isdirectory a/b/c]
    file delete -force a
    set res
} {1}
test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force a}
    catch {file delete -force b}
    file mkdir a/b b/a/c
    set res [list [file isdirectory a/b] [file isdirectory b/a/c]]
    file delete -force a
    file delete -force b
    set res
} {1 1}

# mtime 

set file [makeFile "data" touch.me]

test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
    list [catch {file mtime a b c} msg] $msg
} {1 {wrong # args: should be "file mtime name ?time?"}}
# Check (allowing for clock-skew and OS interrupts as best we can)
# that the change in mtime on a file being written is the time elapsed
# between writes.  Note that this can still fail on very busy systems
# if there are long preemptions between the writes and the reading of
# the clock, but there's not much you can do about that other than the
# completely horrible "keep on trying to write until you managed to do
# it all in less than a second."  - DKF
test cmdAH-24.2 {Tcl_FileObjCmd: mtime} {
    set f [open gorp.file w]
    puts $f "More text"
    set localOld [clock seconds]
    close $f
    set old [file mtime gorp.file]
    after 2000
    set f [open gorp.file w]
    puts $f "More text"
    set localNew [clock seconds]
    close $f
    set new [file mtime gorp.file]
    expr {
	($new > $old) && ($localNew > $localOld) &&
	(abs(($new-$old) - ($localNew-$localOld)) <= 1)
    }
} {1}
test cmdAH-24.3 {Tcl_FileObjCmd: mtime} {
    catch {unset stat}
    file stat gorp.file stat
    list [expr {[file mtime gorp.file] == $stat(mtime)}] \
	    [expr {[file atime gorp.file] == $stat(atime)}]
} {1 1}
test cmdAH-24.4 {Tcl_FileObjCmd: mtime} {
    string tolower [list [catch {file mtime _bogus_} msg] $msg \
	    $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-24.5 {Tcl_FileObjCmd: mtime} {
    # Under Unix, use a file in /tmp to avoid clock skew due to NFS.
    # On other platforms, just use a file in the local directory.

    if {[string equal $tcl_platform(platform) "unix"]} {
	 set name /tmp/tcl.test
    } else {
	set name tf
    }

    # Make sure that a new file's time is correct.  10 seconds variance 
    # is allowed used due to slow networks or clock skew on a network drive.

    file delete -force $name
    close [open $name w]







>






|


|







|
|




|








|




|









|





>
>

|
|
|
|



|
|
|
|



|
|
|
|



|
|
|
|
|
|


















|



|

|



|







|
|
|










|

|







1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
    set atime [file atime $file]
    after 1100; # pause a sec to notice change in atime
    set newatime [clock seconds]
    set modatime [file atime $file $newatime]
    expr {$newatime == $modatime ? 1 : "$newatime != $modatime"}
} 1

removeFile touch.me
# isdirectory

test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} {
    list [catch {file isdirectory a b} msg] $msg
} {1 {wrong # args: should be "file isdirectory name"}}
test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {
    file isdirectory $gorpfile
} 0
test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} {
    file isd $dirfile
} 1

# isfile

test cmdAH-22.1 {Tcl_FileObjCmd: isfile} {
    list [catch {file isfile a b} msg] $msg
} {1 {wrong # args: should be "file isfile name"}}
test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile $gorpfile} 1
test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0

# lstat and readlink:  don't run these tests everywhere, since not all
# sites will have symbolic links

catch {file link -symbolic $linkfile $gorpfile}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} {
    list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.2 {Tcl_FileObjCmd: lstat} {
    list [catch {file lstat a b c} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
    catch {unset stat}
    file lstat $linkfile stat
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
    catch {unset stat}
    file lstat $linkfile stat
    list $stat(nlink) [expr $stat(mode)&0777] $stat(type)
} {1 511 link}
test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {
    string tolower [list [catch {file lstat _bogus_ stat} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} {
    catch {unset x}
    set x 44
    list [catch {file lstat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
catch {unset stat}

# mkdir

set dirA [file join [temporaryDirectory] a]
set dirB [file join [temporaryDirectory] a]
test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    file mkdir $dirA
    set res [file isdirectory $dirA]
    file delete $dirA
    set res
} {1}
test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    file mkdir $dirA/b
    set res [file isdirectory $dirA/b]
    file delete -force $dirA
    set res
} {1}
test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    file mkdir $dirA/b/c
    set res [file isdirectory $dirA/b/c]
    file delete -force $dirA
    set res
} {1}
test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {
    catch {file delete -force $dirA}
    catch {file delete -force $dirB}
    file mkdir $dirA/b $dirB/a/c
    set res [list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c]]
    file delete -force $dirA
    file delete -force $dirB
    set res
} {1 1}

# mtime 

set file [makeFile "data" touch.me]

test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
    list [catch {file mtime a b c} msg] $msg
} {1 {wrong # args: should be "file mtime name ?time?"}}
# Check (allowing for clock-skew and OS interrupts as best we can)
# that the change in mtime on a file being written is the time elapsed
# between writes.  Note that this can still fail on very busy systems
# if there are long preemptions between the writes and the reading of
# the clock, but there's not much you can do about that other than the
# completely horrible "keep on trying to write until you managed to do
# it all in less than a second."  - DKF
test cmdAH-24.2 {Tcl_FileObjCmd: mtime} {
    set f [open $gorpfile w]
    puts $f "More text"
    set localOld [clock seconds]
    close $f
    set old [file mtime $gorpfile]
    after 2000
    set f [open $gorpfile w]
    puts $f "More text"
    set localNew [clock seconds]
    close $f
    set new [file mtime $gorpfile]
    expr {
	($new > $old) && ($localNew > $localOld) &&
	(abs(($new-$old) - ($localNew-$localOld)) <= 1)
    }
} {1}
test cmdAH-24.3 {Tcl_FileObjCmd: mtime} {
    catch {unset stat}
    file stat $gorpfile stat
    list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
	    [expr {[file atime $gorpfile] == $stat(atime)}]
} {1 1}
test cmdAH-24.4 {Tcl_FileObjCmd: mtime} {
    string tolower [list [catch {file mtime _bogus_} msg] $msg \
	    $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-24.5 {Tcl_FileObjCmd: mtime} {
    # Under Unix, use a file in /tmp to avoid clock skew due to NFS.
    # On other platforms, just use a file in the local directory.

    if {[string equal $tcl_platform(platform) "unix"]} {
	set name /tmp/tcl.test.[pid]
    } else {
	set name [file join [temporaryDirectory] tf]
    }

    # Make sure that a new file's time is correct.  10 seconds variance 
    # is allowed used due to slow networks or clock skew on a network drive.

    file delete -force $name
    close [open $name w]
1347
1348
1349
1350
1351
1352
1353
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
test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {
    set mtime [file mtime $file]
    after 1100; # pause a sec to notice change in mtime
    set newmtime [clock seconds]
    set modmtime [file mtime $file $newmtime]
    expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1


# owned

test cmdAH-25.1 {Tcl_FileObjCmd: owned} {
    list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
    file owned gorp.file
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
} {1 {wrong # args: should be "file readlink name"}}
test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} {
    file readlink link.file
} gorp.file
test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}

# size

test cmdAH-27.1 {Tcl_FileObjCmd: size} {
    list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
    set oldsize [file size gorp.file]
    set f [open gorp.file a]
    fconfigure $f -translation lf -eofchar {}
    puts $f "More text"
    close $f
    expr {[file size gorp.file] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
    string tolower [list [catch {file size _bogus_} msg] $msg \
	    $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}

# stat

catch {testsetplatform $platform}

makeFile "Test string" gorp.file
catch {exec chmod 765 gorp.file}

test cmdAH-28.1 {Tcl_FileObjCmd: stat} {
    list [catch {file stat _bogus_} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} {
    list [catch {file stat _bogus_ a b} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat gorp.file stat
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat gorp.file stat
    list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
    catch {unset stat}
    file stat gorp.file stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-28.7 {Tcl_FileObjCmd: stat} {
    catch {unset x}
    set x 44
    list [catch {file stat gorp.file x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
test cmdAH-28.8 {Tcl_FileObjCmd: stat} {
    # Sign extension of purported unsigned short to int.

    close [open foo.test w]
    file stat foo.test stat
    set x [expr {$stat(mode) > 0}]
    file delete foo.test
    set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    # relative paths that resolve to root







|







|











|
|



















|
|



|









>
|
|









|




|




|









|




|
|

|







1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {
    set mtime [file mtime $file]
    after 1100; # pause a sec to notice change in mtime
    set newmtime [clock seconds]
    set modmtime [file mtime $file $newmtime]
    expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
removeFile touch.me

# owned

test cmdAH-25.1 {Tcl_FileObjCmd: owned} {
    list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
    file owned $gorpfile
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
    file owned /
} 0

# readlink

test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
    list [catch {file readlink a b} msg] $msg
} {1 {wrong # args: should be "file readlink name"}}
test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} {
    file readlink $linkfile
} $gorpfile
test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {pcOnly nonPortable} {
    list [catch {file readlink _bogus_} msg] [string tolower $msg] \
	    [string tolower $errorCode]
} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}

# size

test cmdAH-27.1 {Tcl_FileObjCmd: size} {
    list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
    set oldsize [file size $gorpfile]
    set f [open $gorpfile a]
    fconfigure $f -translation lf -eofchar {}
    puts $f "More text"
    close $f
    expr {[file size $gorpfile] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
    string tolower [list [catch {file size _bogus_} msg] $msg \
	    $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}

# stat

catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}

test cmdAH-28.1 {Tcl_FileObjCmd: stat} {
    list [catch {file stat _bogus_} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} {
    list [catch {file stat _bogus_ a b} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat $gorpfile stat
    lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
    catch {unset stat}
    file stat $gorpfile stat
    list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
    catch {unset stat}
    file stat $gorpfile stat
    expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
    string tolower [list [catch {file stat _bogus_ stat} msg] \
	    $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-28.7 {Tcl_FileObjCmd: stat} {
    catch {unset x}
    set x 44
    list [catch {file stat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
test cmdAH-28.8 {Tcl_FileObjCmd: stat} {
    # Sign extension of purported unsigned short to int.

    set filename [makeFile "" foo.text]
    file stat $filename stat
    set x [expr {$stat(mode) > 0}]
    removeFile $filename
    set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
    # stat of root directory was failing.
    # don't care about answer, just that test runs.

    # relative paths that resolve to root
1483
1484
1485
1486
1487
1488
1489
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
    cd $old
    expr {$stat(dev) == 2}
} 0
test cmdAH-28.12 {Tcl_FileObjCmd: stat} {
    # stat(mode) with S_IFREG flag was returned as a negative number
    # if mode_t was a short instead of an unsigned short.

    close [open foo.test w]
    file stat foo.test stat
    file delete foo.test
    expr {$stat(mode) > 0}
} 1
catch {unset stat}

# type

test cmdAH-29.1 {Tcl_FileObjCmd: type} {
    list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-29.2 {Tcl_FileObjCmd: type} {
    file type dir.file
} directory
test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unixOnly nonPortable} {
    set exists [list [file exists link.file] [file exists gorp.file]]
    file delete link.file
    set exists2	[list [file exists link.file] [file exists gorp.file]]
    list $exists $exists2
} {{1 1} {0 1}}
test cmdAH-29.3 {Tcl_FileObjCmd: type} {
    file type gorp.file
} file
test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} {






    exec ln -s a/b/c link.file














    set result [file type link.file]
    file delete link.file

    set result
} link
test cmdAH-29.5 {Tcl_FileObjCmd: type} {
    string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}

# Error conditions

test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
    list [catch {file gorp x} msg] $msg
} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
    list [catch {file ex x} msg] $msg
} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
    list [catch {file is x} msg] $msg
} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
    list [catch {file z x} msg] $msg
} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
    list [catch {file read x} msg] $msg
} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
    list [catch {file s x} msg] $msg
} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
    list [catch {file t x} msg] $msg
} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
    list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}

# channels
# In testing 'file channels', we need to make sure that a channel
# created in one interp isn't visible in another.







|
|
|










|


|
|
|



|

|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>










|


|


|


|


|


|


|







1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
    cd $old
    expr {$stat(dev) == 2}
} 0
test cmdAH-28.12 {Tcl_FileObjCmd: stat} {
    # stat(mode) with S_IFREG flag was returned as a negative number
    # if mode_t was a short instead of an unsigned short.

    set filename [makeFile "" foo.test]
    file stat $filename stat
    removeFile $filename
    expr {$stat(mode) > 0}
} 1
catch {unset stat}

# type

test cmdAH-29.1 {Tcl_FileObjCmd: type} {
    list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-29.2 {Tcl_FileObjCmd: type} {
    file type $dirfile
} directory
test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unixOnly nonPortable} {
    set exists [list [file exists $linkfile] [file exists $gorpfile]]
    file delete $linkfile
    set exists2	[list [file exists $linkfile] [file exists $gorpfile]]
    list $exists $exists2
} {{1 1} {0 1}}
test cmdAH-29.3 {Tcl_FileObjCmd: type} {
    file type $gorpfile
} file
test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly} {
    catch {file delete $linkfile}
    # Unlike [exec ln -s], [file link] requires an existing target
    file link -symbolic $linkfile $gorpfile
    set result [file type $linkfile]
    file delete $linkfile
    set result
} link
if {[string equal $tcl_platform(platform) "windows"]} {
    if {[string index $tcl_platform(osVersion) 0] >= 5 \
      && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
	tcltest::testConstraint linkDirectory 1
    } else {
	tcltest::testConstraint linkDirectory 0
    }
} else {
    tcltest::testConstraint linkDirectory 1
}
test cmdAH-29.4.1 {Tcl_FileObjCmd: type} {linkDirectory} {
    set tempdir [makeDirectory temp]
    set linkdir [file join [temporaryDirectory] link.dir]
    file link -symbolic $linkdir $tempdir
    set result [file type $linkdir]
    file delete $linkdir
    removeDirectory $tempdir
    set result
} link
test cmdAH-29.5 {Tcl_FileObjCmd: type} {
    string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}

# Error conditions

test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
    list [catch {file gorp x} msg] $msg
} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
    list [catch {file ex x} msg] $msg
} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
    list [catch {file is x} msg] $msg
} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
    list [catch {file z x} msg] $msg
} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
    list [catch {file read x} msg] $msg
} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
    list [catch {file s x} msg] $msg
} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
    list [catch {file t x} msg] $msg
} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
    list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}

# channels
# In testing 'file channels', we need to make sure that a channel
# created in one interp isn't visible in another.
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
    string equal [file channels] [file channels *]
} {1}
test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
    lsort [file channels std*]
} [lsort {stdout stderr stdin}]

set newFileId [open gorp.file w]

test cmdAH-31.5 {Tcl_FileObjCmd: channels} {
    set res [file channels $newFileId]
    string equal $newFileId $res
} {1}
test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {
    # Safe interps start out with no channels







|







1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
    string equal [file channels] [file channels *]
} {1}
test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
    lsort [file channels std*]
} [lsort {stdout stderr stdin}]

set newFileId [open $gorpfile w]

test cmdAH-31.5 {Tcl_FileObjCmd: channels} {
    set res [file channels $newFileId]
    string equal $newFileId $res
} {1}
test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {
    # Safe interps start out with no channels
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633

1634
1635
1636
1637
1638
1639

# cleanup
catch {testsetplatform $platform}
catch {unset platform}

# Tcl_ForObjCmd is tested in for.test

catch {exec chmod 777 dir.file}
file delete -force dir.file
file delete gorp.file

file delete link.file

cd $cmdAHwd

::tcltest::cleanupTests
return







|
|
|
>
|





1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680

# cleanup
catch {testsetplatform $platform}
catch {unset platform}

# Tcl_ForObjCmd is tested in for.test

catch {file attributes $dirfile -permissions 0777}
removeDirectory $dirfile
removeFile $gorpfile
# No idea how well [removeFile] copes with links...
file delete $linkfile

cd $cmdAHwd

::tcltest::cleanupTests
return
Changes to tests/cmdInfo.test.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdInfo.test,v 1.6 2001/09/20 01:02:20 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(testcmdinfo) \
	[llength [info commands testcmdinfo]]
set ::tcltest::testConstraints(testcmdtoken) \
	[llength [info commands testcmdtoken]]

test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
test cmdinfo-1.2 {command procedure and clientData} {testcmdinfo} {







|


|



|

|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdInfo.test,v 1.6.4.1 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint testcmdinfo \
	[llength [info commands testcmdinfo]]
::tcltest::testConstraint testcmdtoken \
	[llength [info commands testcmdtoken]]

test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
    testcmdinfo create x1
    testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
test cmdinfo-1.2 {command procedure and clientData} {testcmdinfo} {
Changes to tests/cmdMZ.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
# The tests in this file cover the procedures in tclCmdMZ.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.8.10.1 2002/02/05 02:22:03 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
set tcltest::testConstraints(notLinux) \
	[expr {![string equal Linux $tcl_platform(os)]}]

# Tcl_PwdObjCmd

test cmdMZ-1.1 {Tcl_PwdObjCmd} {
    list [catch {pwd a} msg] $msg
} {1 {wrong # args: should be "pwd"}}
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
    catch pwd
} 0
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
    expr [string length pwd]>0
} 1
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly notLinux} {
    # We don't want this test to run on Linux because they do a
    # permissions caching trick which causes this to fail.  The
    # caching is incorrect, but we have no control over that.

    file delete -force foo
    file mkdir foo
    set cwd [pwd]
    cd foo
    file attr . -permissions 000
    set result [list [catch {pwd} msg] $msg]
    cd $cwd
    file delete -force foo
    set result
} {1 {error getting working directory name: permission denied}}

# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test

# Tcl_RenameObjCmd














|





|













|



>
|
|

|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
# The tests in this file cover the procedures in tclCmdMZ.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.8.10.2 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
set tcltest::testConstraints(nonLinuxOnly) \
	[expr {![string equal Linux $tcl_platform(os)]}]

# Tcl_PwdObjCmd

test cmdMZ-1.1 {Tcl_PwdObjCmd} {
    list [catch {pwd a} msg] $msg
} {1 {wrong # args: should be "pwd"}}
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
    catch pwd
} 0
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
    expr [string length pwd]>0
} 1
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly nonLinuxOnly} {
    # We don't want this test to run on Linux because they do a
    # permissions caching trick which causes this to fail.  The
    # caching is incorrect, but we have no control over that.
    set foodir [file join [temporaryDirectory] foo]
    file delete -force $foodir
    file mkdir $foodir
    set cwd [pwd]
    cd $foodir
    file attr . -permissions 000
    set result [list [catch {pwd} msg] $msg]
    cd $cwd
    file delete -force $foodir
    set result
} {1 {error getting working directory name: permission denied}}

# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test

# Tcl_RenameObjCmd

81
82
83
84
85
86
87
88
89
90
91
92
93
94


95
96
97
98
99
100
101
102

103

104
105
106
107
108
109
110
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
    list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
    list [catch {source a b} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} {
    makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file
    list [catch {source source.file} msg] $msg $errorInfo


} {1 {error in sourced file} {error in sourced file
    while executing
"error "error in sourced file""
    (file "source.file" line 3)
    invoked from within
"source source.file"}}
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
    makeFile {list result} source.file

    source source.file

} result

# Tcl_SplitObjCmd

test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}







|
|



|
|
>
>
|


|

|

|
>
|
>







82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
    list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
    list [catch {source a b} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
    set file [makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file]
    set result [list [catch {source $file} msg] $msg $errorInfo]
    removeFile source.file
    set result
} -match glob -result {1 {error in sourced file} {error in sourced file
    while executing
"error "error in sourced file""
    (file "*" line 3)
    invoked from within
"source $file"}}
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
    set file [makeFile {list result} source.file]
    set result [source $file]
    removeFile source.file
    set result
} result

# Tcl_SplitObjCmd

test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
    list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
157
158
159
160
161
162
163
164


























165
166
167
168
169
170
    # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
# There are no tests for Tcl_TimeObjCmd


























# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
::tcltest::cleanupTests
return







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
    # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
    split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"

# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test

test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} {
    list [catch {time} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
    list [catch {time a b c} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
    list [catch {time a b} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
    time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} {
    regexp {^\d+ microseconds per iteration} [time {format 1}]
} 1
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
    expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
    list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
    while executing
"error foo"
    invoked from within
"time {error foo}"}}

# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test

# cleanup
::tcltest::cleanupTests
return
Changes to tests/compile.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# This file contains tests for the files tclCompile.c, tclCompCmds.c
# and tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compile.test,v 1.13.2.2 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.

catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}













|

<
|
|
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17

18
19
20
21
22
23
24
# This file contains tests for the files tclCompile.c, tclCompCmds.c
# and tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: compile.test,v 1.13.2.3 2002/08/20 20:25:27 das Exp $


package require tcltest 2
namespace import -force ::tcltest::*


# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.

catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
68
69
70
71
72
73
74









75
76
77
78
79
80
81
    catch {unset a}
    proc p {} {
        set ::a(1) 1
        return $::a($::a(1))
    }
    list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}










test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
    catch {unset a}
    set a(1) xyzzyx
    proc p {} {
        global a
        catch {set x 123} a(1)







>
>
>
>
>
>
>
>
>







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
    catch {unset a}
    proc p {} {
        set ::a(1) 1
        return $::a($::a(1))
    }
    list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} {
    catch {unset a}
    proc p {} {
	global a
        set a(1) 1
        return ${a(1)}$::a(1)$a(1)
    }
    list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {111 1 1}

test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
    catch {unset a}
    set a(1) xyzzyx
    proc p {} {
        global a
        catch {set x 123} a(1)
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
# 
# Special section for tests of tclLiteral.c
# The following tests check for incorrect memory handling in
# TclReleaseLiteral. They are only effective when tcl is compiled 
# with TCL_MEM_DEBUG
#
# Special test for leak on interp delete [Bug 467523]. 
set ::tcltest::testConstraints(execCommandExists) [expr {[info commands exec] != ""}]
set ::tcltest::testConstraints(memDebug) [expr {[info commands memory] != ""}]

test compile-12.1 {testing literal leak on interp delete} {memDebug} {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex [lindex $lines 3] 3
    }
    







|
|







259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
# 
# Special section for tests of tclLiteral.c
# The following tests check for incorrect memory handling in
# TclReleaseLiteral. They are only effective when tcl is compiled 
# with TCL_MEM_DEBUG
#
# Special test for leak on interp delete [Bug 467523]. 
::tcltest::testConstraint exec [llength [info commands exec]]
::tcltest::testConstraint memDebug [llength [info commands memory]]

test compile-12.1 {testing literal leak on interp delete} {memDebug} {
    proc getbytes {} {
	set lines [split [memory info] "\n"]
	lindex [lindex $lines 3] 3
    }
    
275
276
277
278
279
280
281
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
	set tmp $end
	set end [getbytes]
    }    
    rename getbytes {}
    set leak [expr {$end - $tmp}]
} 0
# Special test for a memory error in a preliminary fix of [Bug 467523]. 
# It requires executing a helpfile

test compile-12.2 {testing error on literal deletion} {memDebug execCommandExists} {
    makeFile {
	for {set i 0} {$i < 5} {incr i} {
	    namespace eval bar {}
	    namespace delete bar
	}
	puts 0
    } source.file
    set res [catch {
	exec [info nameofexecutable] source.file 
    }]
    catch {::tcltest::removeFile source.file}
    set res
} 0
# Test to catch buffer overrun in TclCompileTokens from buf 530320
test compile-12.3 {check for a buffer overrun} {
    proc crash {} {
	puts $array([expr {a+2}])
    }
    list [catch crash msg] $msg
} {1 {syntax error in expression "a+2": variable references require preceding $}}

# Special test for underestimating the maxStackSize required for a
# compiled command. A failure will cause a segfault in the child 
# process.
test compile-13.1 {testing underestimate of maxStackSize in list cmd} {execCommandExists} {
    set body {set x [list}
    for {set i 0} {$i < 3000} {incr i} {
	append body " $i"
    }
    append body {]; puts OK}
    regsub BODY {proc crash {} {BODY}; crash} $body script
    list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {0 OK}

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return







|
>
|








|

|













|






|










282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
	set tmp $end
	set end [getbytes]
    }    
    rename getbytes {}
    set leak [expr {$end - $tmp}]
} 0
# Special test for a memory error in a preliminary fix of [Bug 467523]. 
# It requires executing a helpfile.  Presumably the child process is
# used because when this test fails, it crashes.
test compile-12.2 {testing error on literal deletion} {memDebug exec} {
    makeFile {
	for {set i 0} {$i < 5} {incr i} {
	    namespace eval bar {}
	    namespace delete bar
	}
	puts 0
    } source.file
    set res [catch {
	exec [interpreter] source.file 
    }]
    catch {removeFile source.file}
    set res
} 0
# Test to catch buffer overrun in TclCompileTokens from buf 530320
test compile-12.3 {check for a buffer overrun} {
    proc crash {} {
	puts $array([expr {a+2}])
    }
    list [catch crash msg] $msg
} {1 {syntax error in expression "a+2": variable references require preceding $}}

# Special test for underestimating the maxStackSize required for a
# compiled command. A failure will cause a segfault in the child 
# process.
test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
    set body {set x [list}
    for {set i 0} {$i < 3000} {incr i} {
	append body " $i"
    }
    append body {]; puts OK}
    regsub BODY {proc crash {} {BODY}; crash} $body script
    list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}

# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return
Changes to tests/encoding.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: encoding.test,v 1.8.18.1 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc toutf {args} {
    global x
    lappend x "toutf $args"
}
proc fromutf {args} {
    global x
    lappend x "fromutf $args"
}

# Some tests require the testencoding command

set ::tcltest::testConstraints(testencoding) \
	[expr {[info commands testencoding] != {}}]
set ::tcltest::testConstraints(exec) \
	[llength [info commands exec]]


# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
    testencoding create foo toutf fromutf
    set old [encoding system]










|

<
|
|
<











<
<
|
<
|
<







1
2
3
4
5
6
7
8
9
10
11
12

13
14

15
16
17
18
19
20
21
22
23
24
25


26

27

28
29
30
31
32
33
34
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: encoding.test,v 1.8.18.2 2002/08/20 20:25:27 das Exp $


package require tcltest 2
namespace import -force ::tcltest::*


proc toutf {args} {
    global x
    lappend x "toutf $args"
}
proc fromutf {args} {
    global x
    lappend x "fromutf $args"
}

# Some tests require the testencoding command


testConstraint testencoding [llength [info commands testencoding]]

testConstraint exec [llength [info commands exec]]


# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested

test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
    testencoding create foo toutf fromutf
    set old [encoding system]
86
87
88
89
90
91
92

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
    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]
    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {

    file mkdir tmp/encoding
    close [open tmp/encoding/junk.enc w]
    close [open tmp/encoding/junk2.enc w]
    cd tmp
    set path [testencoding path]
    testencoding path {}
    catch {unset encodings}
    catch {unset x}
    foreach encoding [encoding names] {
	set encodings($encoding) 1
    }
    testencoding path [list [pwd]]
    foreach encoding [encoding names] {
	if {![info exists encodings($encoding)]} {
	    lappend x $encoding
	}
    }
    testencoding path $path
    cd ..



    file delete -force tmp
    lsort $x
} {junk junk2}

test encoding-5.1 {Tcl_SetSystemEncoding} {
    set old [encoding system]
    encoding system jis0208
    set x [encoding convertto \u4e4e]







>
|
|
|
<














|
>
>
>
|







80
81
82
83
84
85
86
87
88
89
90

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
    fconfigure stdout -encoding jis0208
    set x [fconfigure stdout -encoding]
    fconfigure stdout -encoding $old
    set x
} {jis0208}

test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
    cd [makeDirectory tmp]
    makeDirectory [file join tmp encoding]
    makeFile {} [file join tmp encoding junk.enc]
    makeFile {} [file join tmp encoding junk2.enc]

    set path [testencoding path]
    testencoding path {}
    catch {unset encodings}
    catch {unset x}
    foreach encoding [encoding names] {
	set encodings($encoding) 1
    }
    testencoding path [list [pwd]]
    foreach encoding [encoding names] {
	if {![info exists encodings($encoding)]} {
	    lappend x $encoding
	}
    }
    testencoding path $path
    cd [workingDirectory]
    removeFile [file join tmp encoding junk2.enc]
    removeFile [file join tmp encoding junk.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    lsort $x
} {junk junk2}

test encoding-5.1 {Tcl_SetSystemEncoding} {
    set old [encoding system]
    encoding system jis0208
    set x [encoding convertto \u4e4e]
154
155
156
157
158
159
160
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
    append a $a
    append a $a
    set x [encoding convertfrom jis0208 $a]
    list [string length $x] [string index $x 0]
} "512 \u4e4e"

test encoding-8.1 {Tcl_ExternalToUtf} {
    set f [open dummy w]
    fconfigure $f -translation binary -encoding iso8859-1
    puts -nonewline $f "ab\x8c\xc1g"
    close $f
    set f [open dummy r]
    fconfigure $f -translation binary -encoding shiftjis    
    set x [read $f]
    close $f
    file delete dummy
    set x
} "ab\u4e4eg"

test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
    encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
    set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
    append a $a
    append a $a
    append a $a
    append a $a
    append a $a
    append a $a
    set x [encoding convertto jis0208 $a]
    list [string length $x] [string range $x 0 1]
} "1024 8C"

test encoding-10.1 {Tcl_UtfToExternal} {
    set f [open dummy w]
    fconfigure $f -translation binary -encoding shiftjis
    puts -nonewline $f "ab\u4e4eg"
    close $f
    set f [open dummy r]
    fconfigure $f -translation binary -encoding iso8859-1
    set x [read $f]
    close $f
    file delete dummy
    set x
} "ab\x8c\xc1g"

proc viewable {str} {
    set res ""
    foreach c [split $str {}] {
	if {[string is print $c] && [string is ascii $c]} {







|



|



|



















|



|



|







151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
    append a $a
    append a $a
    set x [encoding convertfrom jis0208 $a]
    list [string length $x] [string index $x 0]
} "512 \u4e4e"

test encoding-8.1 {Tcl_ExternalToUtf} {
    set f [open [file join [temporaryDirectory] dummy] w]
    fconfigure $f -translation binary -encoding iso8859-1
    puts -nonewline $f "ab\x8c\xc1g"
    close $f
    set f [open [file join [temporaryDirectory] dummy] r]
    fconfigure $f -translation binary -encoding shiftjis    
    set x [read $f]
    close $f
    file delete [file join [temporaryDirectory] dummy]
    set x
} "ab\u4e4eg"

test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
    encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
    set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
    append a $a
    append a $a
    append a $a
    append a $a
    append a $a
    append a $a
    set x [encoding convertto jis0208 $a]
    list [string length $x] [string range $x 0 1]
} "1024 8C"

test encoding-10.1 {Tcl_UtfToExternal} {
    set f [open [file join [temporaryDirectory] dummy] w]
    fconfigure $f -translation binary -encoding shiftjis
    puts -nonewline $f "ab\u4e4eg"
    close $f
    set f [open [file join [temporaryDirectory] dummy] r]
    fconfigure $f -translation binary -encoding iso8859-1
    set x [read $f]
    close $f
    file delete [file join [temporaryDirectory] dummy]
    set x
} "ab\x8c\xc1g"

proc viewable {str} {
    set res ""
    foreach c [split $str {}] {
	if {[string is print $c] && [string is ascii $c]} {
235
236
237
238
239
240
241

242
243

244
245
246
247
248
249
250


251
252
253
254
255
256
257
test encoding-11.5.1 {LoadEncodingFile: escape file} {
    viewable [encoding convertto iso2022-jp \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
    set system [encoding system]
    set path [testencoding path]
    encoding system identity

    testencoding path tmp
    file mkdir tmp/encoding

    set f [open tmp/encoding/splat.enc w]
    fconfigure $f -translation binary 
    puts $f "abcdefghijklmnop"
    close $f
    set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
    file delete -force tmp
    catch {file delete encoding}


    testencoding path $path
    encoding system $system
    set x
} {1 {invalid encoding file "splat"}}

# OpenEncodingFile is fully tested by the rest of the tests in this file.








>

|
>
|




|
|
>
>







232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
test encoding-11.5.1 {LoadEncodingFile: escape file} {
    viewable [encoding convertto iso2022-jp \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
    set system [encoding system]
    set path [testencoding path]
    encoding system identity
    cd [temporaryDirectory]
    testencoding path tmp
    makeDirectory tmp
    makeDirectory [file join tmp encoding]
    set f [open [file join tmp encoding splat.enc] w]
    fconfigure $f -translation binary 
    puts $f "abcdefghijklmnop"
    close $f
    set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
    file delete [file join [temporaryDirectory] tmp encoding splat.enc]
    removeDirectory [file join tmp encoding]
    removeDirectory tmp
    cd [workingDirectory]
    testencoding path $path
    encoding system $system
    set x
} {1 {invalid encoding file "splat"}}

# OpenEncodingFile is fully tested by the rest of the tests in this file.

321
322
323
324
325
326
327

328
329
330
331
332
333
334
set ::iso2022uniData [encoding convertfrom iso2022-jp $::iso2022encData]
set ::iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
\u3057\u3087\u3046\u304b\uff1f"


set fid [open iso2022.txt w]
fconfigure $fid -encoding binary
puts -nonewline $fid $::iso2022encData
close $fid

test encoding-23.2 {iso2022-jp escape encoding test} {
    string equal $::iso2022uniData $::iso2022uniData2







>







322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
set ::iso2022uniData [encoding convertfrom iso2022-jp $::iso2022encData]
set ::iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
\u3057\u3087\u3046\u304b\uff1f"

cd [temporaryDirectory]
set fid [open iso2022.txt w]
fconfigure $fid -encoding binary
puts -nonewline $fid $::iso2022encData
close $fid

test encoding-23.2 {iso2022-jp escape encoding test} {
    string equal $::iso2022uniData $::iso2022uniData2
358
359
360
361
362
363
364

365
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
    # read $fis <size> reads size in chars, not raw bytes.
    set fid [open iso2022.txt r]
    fconfigure $fid -encoding iso2022-jp
    set data [read $fid 50]
    close $fid
    set data
} [string range $::iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50


test encoding-24.1 {EscapeFreeProc on open channels} {exec} {


    # Bug #524674 input
    set f [open iso2022.tcl w]
    puts $f {
	set f [open iso2022.txt]
	fconfigure $f -encoding iso2022-jp
	gets $f

    }

    close $f
    exec $::tcltest::tcltest iso2022.tcl
} {}

test encoding-24.2 {EscapeFreeProc on open channels} {exec} {


    # Bug #524674 output
    set f [open iso2022.tcl w]
    puts $f {
	fconfigure stdout -encoding iso2022-jp
	puts ab\u4e4e\u68d9g
	exit

    }

    close $f
    viewable [exec $::tcltest::tcltest iso2022.tcl]
} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"

test encoding-24.3 {EscapeFreeProc on open channels} {exec} {
    # Bug #219314 - if we don't free escape encodings correctly on
    # channel closure, we go boom
    set f [open iso2022.tcl w]
    puts $f {
	encoding system iso2022-jp
	set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
	puts $a
    }
    close $f
    set f [open "|[list $::tcltest::tcltest iso2022.tcl]"]
    fconfigure $f -encoding iso2022-jp
    set count [gets $f line]
    close $f

    list $count [viewable $line]
} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]

::tcltest::removeFile iso2022.txt
::tcltest::removeFile iso2022.tcl

# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::tcltest::cleanupTests
return







>

|
>
>

|
<
|


>
|
>
|
|
|

|
>
>

|
<



>
|
>
|
|
|

|


|
<



<
|
|



>



|
<







360
361
362
363
364
365
366
367
368
369
370
371
372
373

374
375
376
377
378
379
380
381
382
383
384
385
386
387
388

389
390
391
392
393
394
395
396
397
398
399
400
401
402

403
404
405

406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
    # read $fis <size> reads size in chars, not raw bytes.
    set fid [open iso2022.txt r]
    fconfigure $fid -encoding iso2022-jp
    set data [read $fid 50]
    close $fid
    set data
} [string range $::iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
cd [workingDirectory]

test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
	exec
} -setup {
    # Bug #524674 input
    set file [makeFile {

	set f [open [file join [file dirname [info script]] iso2022.txt]]
	fconfigure $f -encoding iso2022-jp
	gets $f
    } iso2022.tcl]
} -body {
    exec [interpreter] $file
} -cleanup {
    removeFile iso2022.tcl
} -result {}

test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
	exec
} -setup {
    # Bug #524674 output
    set file [makeFile {

	fconfigure stdout -encoding iso2022-jp
	puts ab\u4e4e\u68d9g
	exit
    } iso2022.tcl]
} -body {
    viewable [exec [interpreter] $file]
} -cleanup {
    removeFile iso2022.tcl
} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"

test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
    # Bug #219314 - if we don't free escape encodings correctly on
    # channel closure, we go boom
    set file [makeFile {

	encoding system iso2022-jp
	set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
	puts $a

    } iso2022.tcl]
    set f [open "|[list [interpreter] $file]"]
    fconfigure $f -encoding iso2022-jp
    set count [gets $f line]
    close $f
    removeFile iso2022.tcl
    list $count [viewable $line]
} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]

file delete [file join [temporaryDirectory] iso2022.txt]


# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file

# cleanup
::tcltest::cleanupTests
return
Changes to tests/env.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# Commands covered:  none (tests environment variable implementation)
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.13.18.2 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

#
# These tests will run on any platform (and indeed crashed
# on the Mac).  So put them before you test for the existance
# of exec.
#
test env-1.1 {propagation of env values to child interpreters} {













|

<
|
|
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17

18
19
20
21
22
23
24
# Commands covered:  none (tests environment variable implementation)
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.13.18.3 2002/08/20 20:25:27 das Exp $


package require tcltest 2
namespace import -force ::tcltest::*


#
# These tests will run on any platform (and indeed crashed
# on the Mac).  So put them before you test for the existance
# of exec.
#
test env-1.1 {propagation of env values to child interpreters} {
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
    catch {unset env(test)}
    expr {$ix >= 0}
} {1}


# Some tests require the "exec" command.
# Skip them if exec is not defined.
set ::tcltest::testConstraints(execCommandExists) [expr {[info commands exec] != ""}]

set f [open printenv w]
puts $f {
    proc lrem {listname name} {
	upvar $listname list
	set i [lsearch $list $name]
	if {$i >= 0} {
	    set list [lreplace $list $i $i]
	}
	return $list







|

|
<







52
53
54
55
56
57
58
59
60
61

62
63
64
65
66
67
68
    catch {unset env(test)}
    expr {$ix >= 0}
} {1}


# Some tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]

set printenvScript [makeFile {

    proc lrem {listname name} {
	upvar $listname list
	set i [lsearch $list $name]
	if {$i >= 0} {
	    set list [lreplace $list $i $i]
	}
	return $list
81
82
83
84
85
86
87

88
89
90

91
92
93
94
95
96
97
98
99
100
    foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH } {
	lrem names $name
    }
    foreach p $names {
	puts "$p=$env($p)"
    }
    exit

}
close $f
	

proc getenv {} {
    global printenv tcltest
    catch {exec $::tcltest::tcltest printenv} out
    if {$out == "child process exited abnormally"} {
	set out {}
    }
    return $out
}

# Save the current environment variables at the start of the test.







>
|
<
|
>

|
|







78
79
80
81
82
83
84
85
86

87
88
89
90
91
92
93
94
95
96
97
98
    foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH } {
	lrem names $name
    }
    foreach p $names {
	puts "$p=$env($p)"
    }
    exit
} printenv]
	

# [exec] is required here to see the actual environment received
# by child processes.
proc getenv {} {
    global printenvScript tcltest
    catch {exec [interpreter] $printenvScript} out
    if {$out == "child process exited abnormally"} {
	set out {}
    }
    return $out
}

# Save the current environment variables at the start of the test.
109
110
111
112
113
114
115
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
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH} {
  if {[info exists env2($name)]} {
     set env($name) $env2($name);
  }
}

test env-2.1 {adding environment variables} {execCommandExists} {
    getenv
} {}

set env(NAME1) "test string"
test env-2.2 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string}

set env(NAME2) "more"
test env-2.3 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string
NAME2=more}

set env(XYZZY) "garbage"
test env-2.4 {adding environment variables} {execCommandExists} {
    getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}

set env(NAME2) "new value"
test env-3.1 {changing environment variables} {execCommandExists} {
    set result [getenv]
    unset env(NAME2)
    set result
} {NAME1=test string
NAME2=new value
XYZZY=garbage}

test env-4.1 {unsetting environment variables} {execCommandExists} {
    set result [getenv]
    unset env(NAME1)
    set result
} {NAME1=test string
XYZZY=garbage}

test env-4.2 {unsetting environment variables} {execCommandExists} {
    set result [getenv]
    unset env(XYZZY)
    set result
} {XYZZY=garbage}

test env-4.3 {setting international environment variables} {execCommandExists} {
    set env(\ua7) \ub6
    getenv
} "\ua7=\ub6"
test env-4.4 {changing international environment variables} {execCommandExists} {
    set env(\ua7) \ua7
    getenv
} "\ua7=\ua7"
test env-4.5 {unsetting international environment variables} {execCommandExists} {
    set env(\ub6) \ua7
    unset env(\ua7)
    set result [getenv]
    unset env(\ub6)
    set result
} "\ub6=\ua7"








|




|




|





|






|







|






|





|



|



|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH} {
  if {[info exists env2($name)]} {
     set env($name) $env2($name);
  }
}

test env-2.1 {adding environment variables} {exec} {
    getenv
} {}

set env(NAME1) "test string"
test env-2.2 {adding environment variables} {exec} {
    getenv
} {NAME1=test string}

set env(NAME2) "more"
test env-2.3 {adding environment variables} {exec} {
    getenv
} {NAME1=test string
NAME2=more}

set env(XYZZY) "garbage"
test env-2.4 {adding environment variables} {exec} {
    getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}

set env(NAME2) "new value"
test env-3.1 {changing environment variables} {exec} {
    set result [getenv]
    unset env(NAME2)
    set result
} {NAME1=test string
NAME2=new value
XYZZY=garbage}

test env-4.1 {unsetting environment variables} {exec} {
    set result [getenv]
    unset env(NAME1)
    set result
} {NAME1=test string
XYZZY=garbage}

test env-4.2 {unsetting environment variables} {exec} {
    set result [getenv]
    unset env(XYZZY)
    set result
} {XYZZY=garbage}

test env-4.3 {setting international environment variables} {exec} {
    set env(\ua7) \ub6
    getenv
} "\ua7=\ub6"
test env-4.4 {changing international environment variables} {exec} {
    set env(\ua7) \ua7
    getenv
} "\ua7=\ua7"
test env-4.5 {unsetting international environment variables} {exec} {
    set env(\ub6) \ua7
    unset env(\ua7)
    set result [getenv]
    unset env(\ub6)
    set result
} "\ub6=\ua7"

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
    unset env($name)
}
foreach name [array names env2] {
    set env($name) $env2($name)
}

# cleanup
file delete printenv
::tcltest::cleanupTests
return












|







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    unset env($name)
}
foreach name [array names env2] {
    set env($name) $env2($name)
}

# cleanup
removeFile $printenvScript
::tcltest::cleanupTests
return





Changes to tests/event.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl
# commands.  Sourcing this file into Tcl runs the tests and generates
# output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: event.test,v 1.13.8.1 2002/02/05 02:22:03 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(testfilehandler) \
	[expr {[info commands testfilehandler] != {}}]
set ::tcltest::testConstraints(testexithandler) \
	[expr {[info commands testexithandler] != {}}]
set ::tcltest::testConstraints(testfilewait) \
	[expr {[info commands testfilewait] != {}}]

test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
    testfilehandler close
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    set result ""











|

<
|
|
|
<
<
|
<
|
<
|







1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16


17

18

19
20
21
22
23
24
25
26
# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl
# commands.  Sourcing this file into Tcl runs the tests and generates
# output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: event.test,v 1.13.8.2 2002/08/20 20:25:27 das Exp $


package require tcltest 2
namespace import -force ::tcltest::*



testConstraint testfilehandler [llength [info commands testfilehandler]]

testConstraint testexithandler [llength [info commands testexithandler]]

testConstraint testfilewait [llength [info commands testfilewait]]

test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
    testfilehandler close
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    set result ""
193
194
195
196
197
198
199


200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
    rename bgerror {}
    set x
} {{a simple error}}

test event-6.1 {BgErrorDeleteProc procedure} {
    catch {interp delete foo}
    interp create foo


    foo eval {
	proc bgerror args {
	    global errorInfo
	    set f [open err.out r+]
	    seek $f 0 end
	    puts $f "$args $errorInfo"
	    close $f
	}
	after 100 {error "first error"}
	after 100 {error "second error"}
    }
    makeFile Unmodified err.out
    after 100 {interp delete foo}
    after 200
    update
    set f [open err.out r]
    set result [read $f]
    close $f
    removeFile err.out
    set result
} {Unmodified
}

test event-7.1 {bgerror / regular} {
    set errRes {}
    proc bgerror {err} {







>
>


|
|







<



|


|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218
219
220
221
    rename bgerror {}
    set x
} {{a simple error}}

test event-6.1 {BgErrorDeleteProc procedure} {
    catch {interp delete foo}
    interp create foo
    set erroutfile [makeFile Unmodified err.out]
    foo eval [list set erroutfile $erroutfile]
    foo eval {
	proc bgerror args {
	    global errorInfo erroutfile
	    set f [open $erroutfile r+]
	    seek $f 0 end
	    puts $f "$args $errorInfo"
	    close $f
	}
	after 100 {error "first error"}
	after 100 {error "second error"}
    }

    after 100 {interp delete foo}
    after 200
    update
    set f [open $erroutfile r]
    set result [read $f]
    close $f
    removeFile $erroutfile
    set result
} {Unmodified
}

test event-7.1 {bgerror / regular} {
    set errRes {}
    proc bgerror {err} {
281
282
283
284
285
286
287
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
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
    set script {
	after 1000 error hello
	after 2000 set a 0
	vwait a
    }

    list [catch {exec [info nameofexecutable] << $script} errMsg] $errMsg
} {1 {hello
    while executing
"error hello"
    ("after" script)}}


# someday : add a test checking that 
# when there is no bgerror, an error msg goes to stderr
# ideally one would use sub interp and transfer a fake stderr
# to it, unfortunatly the current interp tcl API does not allow
# that. the other option would be to use fork a test but it
# then becomes more a file/exec test than a bgerror test.

# end of bgerror tests
catch {rename bgerror {}}


test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 6
even 4
odd 41
}

test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 41"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 4"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
    } {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 6"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "testexithandler create 41; testexithandler delete 41"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
}

test event-10.1 {Tcl_Exit procedure} {stdio} {
    set child [open |[list [info nameofexecutable]] r+]
    puts $child "exit 3"
    list [catch {close $child} msg] $msg [lindex $errorCode 0] \
        [lindex $errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}

test event-11.1 {Tcl_VwaitCmd procedure} {
    list [catch {vwait} msg] $msg







|


















|












|












|












|












|










|







277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
    set script {
	after 1000 error hello
	after 2000 set a 0
	vwait a
    }

    list [catch {exec [interpreter] << $script} errMsg] $errMsg
} {1 {hello
    while executing
"error hello"
    ("after" script)}}


# someday : add a test checking that 
# when there is no bgerror, an error msg goes to stderr
# ideally one would use sub interp and transfer a fake stderr
# to it, unfortunatly the current interp tcl API does not allow
# that. the other option would be to use fork a test but it
# then becomes more a file/exec test than a bgerror test.

# end of bgerror tests
catch {rename bgerror {}}


test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [interpreter]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 6
even 4
odd 41
}

test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [interpreter]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 41"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [interpreter]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 4"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
    } {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [interpreter]] r+]
    puts $child "testexithandler create 41; testexithandler create 4"
    puts $child "testexithandler create 6; testexithandler delete 6"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
    set child [open |[list [interpreter]] r+]
    puts $child "testexithandler create 41; testexithandler delete 41"
    puts $child "testexithandler create 16; exit"
    flush $child
    set result [read $child]
    close $child
    set result
} {even 16
}

test event-10.1 {Tcl_Exit procedure} {stdio} {
    set child [open |[list [interpreter]] r+]
    puts $child "exit 3"
    list [catch {close $child} msg] $msg [lindex $errorCode 0] \
        [lindex $errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}

test event-11.1 {Tcl_VwaitCmd procedure} {
    list [catch {vwait} msg] $msg
401
402
403
404
405
406
407

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
} {{} x-done y-done before q-done}

foreach i [after info] {
    after cancel $i
}

test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {

    set f1 [open test1 w]
    proc accept {s args} {
	puts $s foobar
	close $s
    }
    catch {set s1 [socket -server accept 0]}
    after 1000
    catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]}
    close $s1
    set x 0
    set y 0
    set z 0
    fileevent $s2 readable { incr z }
    vwait z
    fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
    fileevent $s2 readable { incr y; if { $x == 3 } { set z done } }
    vwait z
    close $f1
    close $s2
    file delete test1 test2
    list $x $y $z
} {3 3 done}
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
    file delete test1 test2

    set f1 [open test1 w]
    set f2 [open test2 w]
    set x 0
    set y 0
    set z 0
    update
    fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
    fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
    vwait z
    close $f1
    close $f2
    file delete test1 test2

    list $x $y $z
} {3 3 done}


test event-12.1 {Tcl_UpdateCmd procedure} {
    list [catch {update a b} msg] $msg
} {1 {wrong # args: should be "update ?idletasks?"}}







>
|











|

|
|



|



|
>
|
|




|
|



|
>







397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
} {{} x-done y-done before q-done}

foreach i [after info] {
    after cancel $i
}

test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
    set test1file [makeFile "" test1]
    set f1 [open $test1file w]
    proc accept {s args} {
	puts $s foobar
	close $s
    }
    catch {set s1 [socket -server accept 0]}
    after 1000
    catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]}
    close $s1
    set x 0
    set y 0
    set z 0
    fileevent $s2 readable {incr z}
    vwait z
    fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
    fileevent $s2 readable {incr y; if {$x == 3} {set z done}}
    vwait z
    close $f1
    close $s2
    removeFile $test1file
    list $x $y $z
} {3 3 done}
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
    set test1file [makeFile "" test1]
    set test2file [makeFile "" test2]
    set f1 [open $test1file w]
    set f2 [open $test2file w]
    set x 0
    set y 0
    set z 0
    update
    fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
    fileevent $f2 writable {incr y; if {$x == 3} {set z done}}
    vwait z
    close $f1
    close $f2
    removeFile $test1file
    removeFile $test2file
    list $x $y $z
} {3 3 done}


test event-12.1 {Tcl_UpdateCmd procedure} {
    list [catch {update a b} msg] $msg
} {1 {wrong # args: should be "update ?idletasks?"}}
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607

# cleanup
foreach i [after info] {
    after cancel $i
}
::tcltest::cleanupTests
return



















<
<
<
<
<
<
<
<
<
<
<
<
588
589
590
591
592
593
594













# cleanup
foreach i [after info] {
    after cancel $i
}
::tcltest::cleanupTests
return












Changes to tests/exec.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
# Commands covered:  exec
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: exec.test,v 1.8.18.1 2002/02/05 02:22:03 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# All tests require the "exec" command.
# Skip them if exec is not defined.
set ::tcltest::testConstraints(execCommandExists) [expr {[info commands exec] != ""}]

set f [open echo w]
puts $f {
    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
    puts {}
    exit
}
close $f

set f [open cat w]
puts $f {
    if {$argv == {}} {
	set argv -
    }
    foreach name $argv {
	if {$name == "-"} {
	    set f stdin
	} elseif {[catch {open $name r} f] != 0} {
	    puts stderr $f
	    continue
	}
	while {[eof $f] == 0} {
	    puts -nonewline [read $f]
	}
	if {$f != "stdin"} {
	    close $f
	}
    }
    exit
}
close $f

set f [open wc w]
puts $f {
    set data [read stdin]
    set lines [regsub -all "\n" $data {} dummy]
    set words [regsub -all "\[^ \t\n]+" $data {} dummy]
    set chars [string length $data]
    puts [format "%8.d%8.d%8.d" $lines $words $chars]
    exit
}
close $f

set f [open sh w]
puts $f {
    if {[lindex $argv 0] != "-c"} {
	error "sh: unexpected arguments $argv"
    }
    set cmd [lindex $argv 1]
    lappend cmd ";"

    set newcmd {}
    
    foreach arg $cmd {
	if {$arg == ";"} {
	    eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd
	    set newcmd {}
	    continue
	}
	if {$arg == "1>&2"} {
	    set arg >@stderr
	}
	lappend newcmd $arg
    }
    exit
}
close $f

set f [open sleep w]
puts $f {
    after [expr $argv*1000]
    exit
}
close $f

set f [open exit w]
puts $f {
    exit $argv
}
close $f

# Basic operations.

test exec-1.1 {basic exec operation} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo a b c
} "a b c"
test exec-1.2 {pipelining} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo a b c d | $::tcltest::tcltest cat | $::tcltest::tcltest cat
} "a b c d"
test exec-1.3 {pipelining} {execCommandExists stdio} {
    set a [exec $::tcltest::tcltest echo a b c d | $::tcltest::tcltest cat | $::tcltest::tcltest wc]
    list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo $arg
} $arg
set arg {}

# I/O redirection: input from Tcl command.

test exec-2.1 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {execCommandExists stdio} {
    exec << "Sample text" $::tcltest::tcltest cat | $::tcltest::tcltest cat
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat << "Sample text" | $::tcltest::tcltest cat
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat | $::tcltest::tcltest cat << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} {execCommandExists stdio} {
    # If this fails, it may give back:
    # "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
    # If it does, this means that the UTF -> external conversion did not 
    # occur before writing out the temp file.
    exec $::tcltest::tcltest cat << "\uE9\uE0\uFC\uF1"
} "\uE9\uE0\uFC\uF1"

# I/O redirection: output to file.


file delete gorp.file

test exec-3.1 {redirecting output to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "Some simple words" > gorp.file
    exec $::tcltest::tcltest cat gorp.file
} "Some simple words"
test exec-3.2 {redirecting output to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "More simple words" | >gorp.file $::tcltest::tcltest cat | $::tcltest::tcltest cat
    exec $::tcltest::tcltest cat gorp.file
} "More simple words"
test exec-3.3 {redirecting output to file} {execCommandExists stdio} {
    exec > gorp.file $::tcltest::tcltest echo "Different simple words" | $::tcltest::tcltest cat | $::tcltest::tcltest cat
    exec $::tcltest::tcltest cat gorp.file
} "Different simple words"
test exec-3.4 {redirecting output to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "Some simple words" >gorp.file
    exec $::tcltest::tcltest cat gorp.file
} "Some simple words"
test exec-3.5 {redirecting output to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "First line" >gorp.file
    exec $::tcltest::tcltest echo "Second line" >> gorp.file
    exec $::tcltest::tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "First line" >gorp.file
    exec $::tcltest::tcltest echo "Second line" >>gorp.file
    exec $::tcltest::tcltest cat gorp.file
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $::tcltest::tcltest echo "More text" >@ $f
    exec $::tcltest::tcltest echo >@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $::tcltest::tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"

# I/O redirection: output and stderr to file.

file delete gorp.file

test exec-4.1 {redirecting output and stderr to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "test output" >& gorp.file
    exec $::tcltest::tcltest cat gorp.file
} "test output"
test exec-4.2 {redirecting output and stderr to file} {execCommandExists stdio} {
    list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
	    [exec $::tcltest::tcltest cat gorp.file]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "first line" > gorp.file
    list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
	    [exec $::tcltest::tcltest cat gorp.file]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $::tcltest::tcltest echo "More text" >&@ $f
    exec $::tcltest::tcltest echo >&@$f "Even more"
    puts $f "Line 3"
    close $f
    exec $::tcltest::tcltest cat gorp.file
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec >&@ $f $::tcltest::tcltest sh -c "echo foo bar 1>&2"
    exec >&@$f $::tcltest::tcltest sh -c "echo xyzzy 1>&2"
    puts $f "Line 3"
    close $f
    exec $::tcltest::tcltest cat gorp.file
} "Line 1\nfoo bar\nxyzzy\nLine 3"

# I/O redirection: input from file.

if { [set ::tcltest::testConstraints(execCommandExists)] } {
exec $::tcltest::tcltest echo "Just a few thoughts" > gorp.file
}
test exec-5.1 {redirecting input from file} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat | $::tcltest::tcltest cat < gorp.file
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat < gorp.file | $::tcltest::tcltest cat
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {execCommandExists stdio} {
    exec < gorp.file $::tcltest::tcltest cat | $::tcltest::tcltest cat
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat <gorp.file
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {execCommandExists stdio} {
    set f [open gorp.file r]
    set result [exec $::tcltest::tcltest cat <@ $f]
    close $f
    set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {execCommandExists stdio} {
    set f [open gorp.file r]
    set result [exec <@$f $::tcltest::tcltest cat]
    close $f
    set result
} {Just a few thoughts}

# I/O redirection: standard error through a pipeline.

test exec-6.1 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $::tcltest::tcltest sh -c "echo foo bar" |& $::tcltest::tcltest cat
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" |& $::tcltest::tcltest cat
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {execCommandExists stdio} {
    exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" \
	|& $::tcltest::tcltest sh -c "echo second msg 1>&2 ; cat" |& $::tcltest::tcltest cat
} "second msg\nfoo bar"

# I/O redirection: combinations.


file delete gorp.file2

test exec-7.1 {multiple I/O redirections} {execCommandExists stdio} {
    exec << "command input" > gorp.file2 $::tcltest::tcltest cat < gorp.file
    exec $::tcltest::tcltest cat gorp.file2
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {execCommandExists stdio} {
    exec < gorp.file << "command input" $::tcltest::tcltest cat
} {command input}

# Long input to command and output from command.

set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {execCommandExists stdio} {
    exec $::tcltest::tcltest cat << $a
} $a

# More than 20 arguments to exec.

test exec-8.1 {long input and output} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}

# Commands that return errors.

test exec-9.1 {commands returning errors} {execCommandExists stdio} {
    set x [catch {exec gorp456} msg]
    list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {execCommandExists stdio} {
    string tolower [list [catch {exec $::tcltest::tcltest echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest sleep 1 | $::tcltest::tcltest exit 43 | $::tcltest::tcltest sleep 1} msg] $msg
} {1 {child process exited abnormally}}
test exec-9.4 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest exit 43 | $::tcltest::tcltest echo "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
test exec-9.5 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec gorp456 | $::tcltest::tcltest echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
test exec-9.6 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg}}
test exec-9.7 {commands returning errors} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest sh -c "echo error msg 1>&2" \
		     | $::tcltest::tcltest sh -c "echo error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}



test exec-9.8 {commands returning errors} {execCommandExists stdio} {
    set f [open err w]
    puts $f {
	puts stdout out
	puts stderr err
    }
    close $f
    list [catch {exec $::tcltest::tcltest err} msg] $msg
} {1 {out
err}}

# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.

test exec-10.1 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-10.2 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open gorp.file w]
test exec-10.18 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
set f [open gorp.file r]
test exec-10.19 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
close $f
test exec-10.20 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}

# Commands in background.

test exec-11.1 {commands in background} {execCommandExists stdio} {
    set x [lindex [time {exec $::tcltest::tcltest sleep 2 &}] 0]
    expr $x<1000000
} 1
test exec-11.2 {commands in background} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest echo a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {execCommandExists stdio} {
    llength [exec $::tcltest::tcltest sleep 1 &]
} 1
test exec-11.4 {commands in background} {execCommandExists stdio} {
    llength [exec $::tcltest::tcltest sleep 1 | $::tcltest::tcltest sleep 1 | $::tcltest::tcltest sleep 1 &]
} 3
test exec-11.5 {commands in background} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f { catch { exec [info nameofexecutable] echo foo & } }
    close $f
    string compare "foo" [exec $::tcltest::tcltest gorp.file]
} 0

# Make sure that background commands are properly reaped when
# they eventually die.

if { [set ::tcltest::testConstraints(execCommandExists)] } {
exec $::tcltest::tcltest sleep 3
}
test exec-12.1 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    for {set i 0} {$i < 20} {incr i} {
	exec echo foo > /dev/null &
    }
    exec sleep 1
    catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
    lindex $msg 0
} 0
test exec-12.2 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    exec sleep 2 | sleep 2 | sleep 2 &
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    set x [lindex $msg 0]
    exec sleep 3
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} \
	{execCommandExists stdio unixOnly nonPortable} {
    exec sleep 1000 &
    exec sleep 1000 &
    set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
    set pids {}
    foreach i [split $x \n] {
	lappend pids [lindex $i 0]
    }













|

<
|
|
<



|

|
<






|
<

|
<


















|
<

|
<






|
<

|
<




















|
<

|
<


|
<

|
<

|
<



|
|

|
|

|
|




|
|





|
|

|
|

|
|

|
|

|
|

|




|




>
|
>
|
|
|

|
|
|

|
|
|

|
|
|

|
|
|
|

|
|
|
|

|
|


|
|


|




|
>
|
|
|

|
|
|

|
|
|
|

|
|


|
|


|

|
|


|
|


|




|
|

|
|

|
|

|
|

|
|

|
|

|
|
|



|
|
|






|
|

|
|

|
|
|




>
|
>
|
|
|

|
|









|
|




|
|




|



|
|

|
|

|
|


|
|

|
|

|
|
|


>
>
>
|
|





|






|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|


|
|



|
|



|


|
|




|
|


|
|

|
|

|
|

|
|
|

|





|
|


|








|








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17

18
19
20
21
22
23

24
25
26
27
28
29
30

31
32

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

52
53

54
55
56
57
58
59
60

61
62

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83

84
85

86
87
88

89
90

91
92

93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
# Commands covered:  exec
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: exec.test,v 1.8.18.2 2002/08/20 20:25:27 das Exp $


package require tcltest 2
namespace import -force ::tcltest::*


# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]

set path(echo) [makeFile {

    puts -nonewline [lindex $argv 0]
    foreach str [lrange $argv 1 end] {
	puts -nonewline " $str"
    }
    puts {}
    exit
} echo]


set path(cat) [makeFile {

    if {$argv == {}} {
	set argv -
    }
    foreach name $argv {
	if {$name == "-"} {
	    set f stdin
	} elseif {[catch {open $name r} f] != 0} {
	    puts stderr $f
	    continue
	}
	while {[eof $f] == 0} {
	    puts -nonewline [read $f]
	}
	if {$f != "stdin"} {
	    close $f
	}
    }
    exit
} cat]


set path(wc) [makeFile {

    set data [read stdin]
    set lines [regsub -all "\n" $data {} dummy]
    set words [regsub -all "\[^ \t\n]+" $data {} dummy]
    set chars [string length $data]
    puts [format "%8.d%8.d%8.d" $lines $words $chars]
    exit
} wc]


set path(sh) [makeFile {

    if {[lindex $argv 0] != "-c"} {
	error "sh: unexpected arguments $argv"
    }
    set cmd [lindex $argv 1]
    lappend cmd ";"

    set newcmd {}
    
    foreach arg $cmd {
	if {$arg == ";"} {
	    eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd
	    set newcmd {}
	    continue
	}
	if {$arg == "1>&2"} {
	    set arg >@stderr
	}
	lappend newcmd $arg
    }
    exit
} sh]


set path(sleep) [makeFile {

    after [expr $argv*1000]
    exit
} sleep]


set path(exit) [makeFile {

    exit $argv
} exit]


# Basic operations.

test exec-1.1 {basic exec operation} {exec} {
    exec [interpreter] $path(echo) a b c
} "a b c"
test exec-1.2 {pipelining} {exec stdio} {
    exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(cat)
} "a b c d"
test exec-1.3 {pipelining} {exec stdio} {
    set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)]
    list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {exec} {
    exec [interpreter] $path(echo) $arg
} $arg
set arg {}

# I/O redirection: input from Tcl command.

test exec-2.1 {redirecting input from immediate source} {exec stdio} {
    exec [interpreter] $path(cat) << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {exec stdio} {
    exec << "Sample text" [interpreter] $path(cat) | [interpreter] $path(cat)
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {exec stdio} {
    exec [interpreter] $path(cat) << "Sample text" | [interpreter] $path(cat)
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {exec stdio} {
    exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {exec} {
    exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} {exec} {
    # If this fails, it may give back:
    # "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
    # If it does, this means that the UTF -> external conversion did not 
    # occur before writing out the temp file.
    exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"
} "\uE9\uE0\uFC\uF1"

# I/O redirection: output to file.

set path(gorp.file) [makeFile {} gorp.file]
removeFile gorp.file

test exec-3.1 {redirecting output to file} {exec} {
    exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file)
} "Some simple words"
test exec-3.2 {redirecting output to file} {exec stdio} {
    exec [interpreter] $path(echo) "More simple words" | >$path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
    exec [interpreter] $path(cat) $path(gorp.file)
} "More simple words"
test exec-3.3 {redirecting output to file} {exec stdio} {
    exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat)
    exec [interpreter] $path(cat) $path(gorp.file)
} "Different simple words"
test exec-3.4 {redirecting output to file} {exec} {
    exec [interpreter] $path(echo) "Some simple words" >$path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file)
} "Some simple words"
test exec-3.5 {redirecting output to file} {exec} {
    exec [interpreter] $path(echo) "First line" >$path(gorp.file)
    exec [interpreter] $path(echo) "Second line" >> $path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file)
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {exec} {
    exec [interpreter] $path(echo) "First line" >$path(gorp.file)
    exec [interpreter] $path(echo) "Second line" >>$path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file)
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {exec} {
    set f [open $path(gorp.file) w]
    puts $f "Line 1"
    flush $f
    exec [interpreter] $path(echo) "More text" >@ $f
    exec [interpreter] $path(echo) >@$f "Even more"
    puts $f "Line 3"
    close $f
    exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"

# I/O redirection: output and stderr to file.

removeFile gorp.file

test exec-4.1 {redirecting output and stderr to file} {exec} {
    exec [interpreter] $path(echo) "test output" >& $path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file)
} "test output"
test exec-4.2 {redirecting output and stderr to file} {exec} {
    list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" >&$path(gorp.file)] \
	    [exec [interpreter] $path(cat) $path(gorp.file)]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {exec} {
    exec [interpreter] $path(echo) "first line" > $path(gorp.file)
    list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" >>&$path(gorp.file)] \
	    [exec [interpreter] $path(cat) $path(gorp.file)]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {exec} {
    set f [open $path(gorp.file) w]
    puts $f "Line 1"
    flush $f
    exec [interpreter] $path(echo) "More text" >&@ $f
    exec [interpreter] $path(echo) >&@$f "Even more"
    puts $f "Line 3"
    close $f
    exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {exec} {
    set f [open $path(gorp.file) w]
    puts $f "Line 1"
    flush $f
    exec >&@ $f [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2"
    exec >&@$f [interpreter] $path(sh) -c "$path(echo) xyzzy 1>&2"
    puts $f "Line 3"
    close $f
    exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nfoo bar\nxyzzy\nLine 3"

# I/O redirection: input from file.

if { [set ::tcltest::testConstraints(exec)] } {
exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file)
}
test exec-5.1 {redirecting input from file} {exec} {
    exec [interpreter] $path(cat) < $path(gorp.file)
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {exec stdio} {
    exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file)
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {exec stdio} {
    exec [interpreter] $path(cat) < $path(gorp.file) | [interpreter] $path(cat)
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {exec stdio} {
    exec < $path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {exec} {
    exec [interpreter] $path(cat) <$path(gorp.file)
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {exec} {
    set f [open $path(gorp.file) r]
    set result [exec [interpreter] $path(cat) <@ $f]
    close $f
    set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {exec} {
    set f [open $path(gorp.file) r]
    set result [exec <@$f [interpreter] $path(cat)]
    close $f
    set result
} {Just a few thoughts}

# I/O redirection: standard error through a pipeline.

test exec-6.1 {redirecting stderr through a pipeline} {exec stdio} {
    exec [interpreter] $path(sh) -c "$path(echo) foo bar" |& [interpreter] $path(cat)
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {exec stdio} {
    exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" |& [interpreter] $path(cat)
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
    exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
	|& [interpreter] $path(sh) -c "$path(echo) second msg 1>&2 ; $path(cat)" |& [interpreter] $path(cat)
} "second msg\nfoo bar"

# I/O redirection: combinations.

set path(gorp.file2) [makeFile {} gorp.file2]
removeFile gorp.file2

test exec-7.1 {multiple I/O redirections} {exec} {
    exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file2)
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {exec} {
    exec < $path(gorp.file) << "command input" [interpreter] $path(cat)
} {command input}

# Long input to command and output from command.

set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {exec} {
    exec [interpreter] $path(cat) << $a
} $a

# More than 20 arguments to exec.

test exec-8.2 {long input and output} {exec} {
    exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}

# Commands that return errors.

test exec-9.1 {commands returning errors} {exec} {
    set x [catch {exec gorp456} msg]
    list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {exec} {
    string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} {exec stdio} {
    list [catch {exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1} msg] $msg
} {1 {child process exited abnormally}}
test exec-9.4 {commands returning errors} {exec stdio} {
    list [catch {exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
test exec-9.5 {commands returning errors} {exec stdio} {
    list [catch {exec gorp456 | [interpreter] echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
test exec-9.6 {commands returning errors} {exec} {
    list [catch {exec [interpreter] $path(sh) -c "$path(echo) error msg 1>&2"} msg] $msg
} {1 {error msg}}
test exec-9.7 {commands returning errors} {exec stdio} {
    list [catch {exec [interpreter] $path(sh) -c "$path(echo) error msg 1>&2" \
		     | [interpreter] $path(sh) -c "$path(echo) error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}

set path(err) [makeFile {} err]

test exec-9.8 {commands returning errors} {exec} {
    set f [open $path(err) w]
    puts $f {
	puts stdout out
	puts stderr err
    }
    close $f
    list [catch {exec [interpreter] $path(err)} msg] $msg
} {1 {out
err}}

# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.

test exec-10.1 {errors in exec invocation} {exec} {
    list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-10.2 {errors in exec invocation} {exec} {
    list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {exec} {
    list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {exec} {
    list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {exec} {
    list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {exec} {
    list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {exec} {
    list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {exec} {
    list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {exec} {
    list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {exec} {
    list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {exec} {
    list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {exec} {
    list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {exec} {
    list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {exec} {
    list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {exec} {
    list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {exec} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {exec} {
    list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open $path(gorp.file) w]
test exec-10.18 {errors in exec invocation} {exec} {
    list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
set f [open $path(gorp.file) r]
test exec-10.19 {errors in exec invocation} {exec} {
    list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
close $f
test exec-10.20 {errors in exec invocation} {exec} {
    list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {exec} {
    list [catch {exec [interpreter] true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}

# Commands in background.

test exec-11.1 {commands in background} {exec} {
    set x [lindex [time {exec [interpreter] $path(sleep) 2 &}] 0]
    expr $x<1000000
} 1
test exec-11.2 {commands in background} {exec} {
    list [catch {exec [interpreter] $path(echo) a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {exec} {
    llength [exec [interpreter] $path(sleep) 1 &]
} 1
test exec-11.4 {commands in background} {exec stdio} {
    llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &]
} 3
test exec-11.5 {commands in background} {exec} {
    set f [open $path(gorp.file) w]
    puts $f [format { catch { exec [info nameofexecutable] %s foo & } } $path(echo)]
    close $f
    string compare "foo" [exec [interpreter] $path(gorp.file)]
} 0

# Make sure that background commands are properly reaped when
# they eventually die.

if { [set ::tcltest::testConstraints(exec)] } {
exec [interpreter] $path(sleep) 3
}
test exec-12.1 {reaping background processes} \
	{exec unixOnly nonPortable} {
    for {set i 0} {$i < 20} {incr i} {
	exec echo foo > /dev/null &
    }
    exec sleep 1
    catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
    lindex $msg 0
} 0
test exec-12.2 {reaping background processes} \
	{exec unixOnly nonPortable} {
    exec sleep 2 | sleep 2 | sleep 2 &
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    set x [lindex $msg 0]
    exec sleep 3
    catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} \
	{exec unixOnly nonPortable} {
    exec sleep 1000 &
    exec sleep 1000 &
    set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
    set pids {}
    foreach i [split $x \n] {
	lappend pids [lindex $i 0]
    }
475
476
477
478
479
480
481
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

    }
    catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {2 0}

# Make sure "errorCode" is set correctly.

test exec-13.1 {setting errorCode variable} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest cat < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {execCommandExists stdio} {
    list [catch {exec $::tcltest::tcltest cat > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {execCommandExists stdio} {
    set x [catch {exec _weird_cmd_} msg]
    list $x [string tolower $msg] [lindex $errorCode 0] \
	    [string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}

# Switches before the first argument

test exec-14.1 {-keepnewline switch} {execCommandExists stdio} {
    exec -keepnewline $::tcltest::tcltest echo foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {execCommandExists stdio} {
    list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-14.3 {unknown switch} {execCommandExists stdio} {
    list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
test exec-14.4 {-- switch} {execCommandExists stdio} {
    list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}

# Redirecting standard error separately from standard output

test exec-15.1 {standard error redirection} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "First line" > gorp.file
    list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
	    [exec $::tcltest::tcltest cat gorp.file]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {execCommandExists stdio} {
    list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" \
		| $::tcltest::tcltest echo biz baz >gorp.file 2> gorp.file2] \
	    [exec $::tcltest::tcltest cat gorp.file] \
	    [exec $::tcltest::tcltest cat gorp.file2]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {execCommandExists stdio} {
    list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" \
	        | $::tcltest::tcltest echo biz baz 2>gorp.file > gorp.file2] \
	    [exec $::tcltest::tcltest cat gorp.file] \
	    [exec $::tcltest::tcltest cat gorp.file2]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "Line 1"
    flush $f
    exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" 2>@ $f
    puts $f "Line 3"
    close $f
    exec $::tcltest::tcltest cat gorp.file
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {execCommandExists stdio} {
    exec $::tcltest::tcltest echo "First line" > gorp.file
    exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
    exec $::tcltest::tcltest cat gorp.file
} {First line
foo bar}
test exec-15.6 {standard error redirection} {execCommandExists stdio} {
    exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
	    >& gorp.file 2> gorp.file2 | $::tcltest::tcltest echo biz baz
    list [exec $::tcltest::tcltest cat gorp.file] [exec $::tcltest::tcltest cat gorp.file2]
} {{biz baz} {foo bar}}



test exec-16.1 {flush output before exec} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $::tcltest::tcltest echo "Second line" >@ $f
    puts $f "Third line"
    close $f
    exec $::tcltest::tcltest cat gorp.file
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {execCommandExists stdio} {
    set f [open gorp.file w]
    puts $f "First line"
    exec $::tcltest::tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
    puts $f "Third line"
    close $f
    exec $::tcltest::tcltest cat gorp.file
} {First line
Second line
Third line}



test exec-17.1 { inheriting standard I/O } {execCommandExists stdio} {
    set f [open script w]
    puts $f {close stdout
	set f [open gorp.file w]
	catch {exec [info nameofexecutable] echo foobar &}
	exec [info nameofexecutable] sleep 2
	close $f
    }

    close $f
    catch {exec $::tcltest::tcltest script} result
    set f [open gorp.file r]
    lappend result [read $f]
    close $f
    set result
} {{foobar
}}

# cleanup
file delete script gorp.file gorp.file2
file delete echo cat wc sh sleep exit
file delete err
::tcltest::cleanupTests
return




















|
|

|
|

|







|
|

|


|


|





|
|
|
|

|
|
|
|
|

|
|
|
|
|

|
|


|


|



|
|
|
|


|
|
|
<
<
>
>

|
|

|


|



|
|

|


|




>
>
|
|
|
|
|
|

<
>

|
|






|
|
|
|
|
|
|
|
|
|

|

|
|
|

|
>
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541


542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574

575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
    }
    catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
    list $x [lindex $msg 0]
} {2 0}

# Make sure "errorCode" is set correctly.

test exec-13.1 {setting errorCode variable} {exec} {
    list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {exec} {
    list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {exec} {
    set x [catch {exec _weird_cmd_} msg]
    list $x [string tolower $msg] [lindex $errorCode 0] \
	    [string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}

# Switches before the first argument

test exec-14.1 {-keepnewline switch} {exec} {
    exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {exec} {
    list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-14.3 {unknown switch} {exec} {
    list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
test exec-14.4 {-- switch} {exec} {
    list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}

# Redirecting standard error separately from standard output

test exec-15.1 {standard error redirection} {exec} {
    exec [interpreter] $path(echo) "First line" > $path(gorp.file)
    list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2> $path(gorp.file)] \
	    [exec [interpreter] $path(cat) $path(gorp.file)]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {exec stdio} {
    list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
		| [interpreter] $path(echo) biz baz >$path(gorp.file) 2> $path(gorp.file2)] \
	    [exec [interpreter] $path(cat) $path(gorp.file)] \
	    [exec [interpreter] $path(cat) $path(gorp.file2)]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {exec stdio} {
    list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
	        | [interpreter] $path(echo) biz baz 2>$path(gorp.file) > $path(gorp.file2)] \
	    [exec [interpreter] $path(cat) $path(gorp.file)] \
	    [exec [interpreter] $path(cat) $path(gorp.file2)]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {exec} {
    set f [open $path(gorp.file) w]
    puts $f "Line 1"
    flush $f
    exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2>@ $f
    puts $f "Line 3"
    close $f
    exec [interpreter] $path(cat) $path(gorp.file)
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {exec} {
    exec [interpreter] $path(echo) "First line" > $path(gorp.file)
    exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2>> $path(gorp.file)
    exec [interpreter] $path(cat) $path(gorp.file)
} {First line
foo bar}
test exec-15.6 {standard error redirection} {exec stdio} {
    exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" > $path(gorp.file2) 2> $path(gorp.file) \
	    >& $path(gorp.file) 2> $path(gorp.file2) | [interpreter] $path(echo) biz baz


    list [exec [interpreter] $path(cat) $path(gorp.file)] [exec [interpreter] $path(cat) $path(gorp.file2)]
} {{biz baz} {foo bar}}

test exec-16.1 {flush output before exec} {exec} {
    set f [open $path(gorp.file) w]
    puts $f "First line"
    exec [interpreter] $path(echo) "Second line" >@ $f
    puts $f "Third line"
    close $f
    exec [interpreter] $path(cat) $path(gorp.file)
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {exec} {
    set f [open $path(gorp.file) w]
    puts $f "First line"
    exec [interpreter] << {puts stderr {Second line}} >&@ $f > $path(gorp.file2)
    puts $f "Third line"
    close $f
    exec [interpreter] $path(cat) $path(gorp.file)
} {First line
Second line
Third line}

set path(script) [makeFile {} script]

test exec-17.1 { inheriting standard I/O } {exec} {
    set f [open $path(script) w]
    puts $f [format {close stdout
	set f [open %s w]
	catch {exec [info nameofexecutable] %s foobar &}
	exec [info nameofexecutable] %s 2
	close $f

    } $path(gorp.file) $path(echo) $path(sleep)]
    close $f
    catch {exec [interpreter] $path(script)} result
    set f [open $path(gorp.file) r]
    lappend result [read $f]
    close $f
    set result
} {{foobar
}}

test exec-18.1 { exec cat deals with weird file names} {exec} {
    set f "foo\[\{blah"
    set path(fooblah) [makeFile {} $f]
    set fout [open $path(fooblah) w]
    puts $fout "contents"
    close $fout
    set res [list [catch {exec cat $path(fooblah)} msg] $msg]
    removeFile $f
    set res
} {0 contents}

# cleanup

foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} {
	removeFile $file
}

::tcltest::cleanupTests
return
Changes to tests/execute.test.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: execute.test,v 1.9.14.1 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}

set ::tcltest::testConstraints(testobj) \
	[expr {[info commands testobj] != {} \
	&& [info commands testdoubleobj] != {} \
	&& [info commands teststringobj] != {} \
	&& [info commands testobj] != {}}]

set ::tcltest::testConstraints(longIs32bit) \
	[expr {int(0x80000000) < 0}]

# Tests for the omnibus TclExecuteByteCode function:

# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested







|


|









|





|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: execute.test,v 1.9.14.2 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}

::tcltest::testConstraint testobj \
	[expr {[info commands testobj] != {} \
	&& [info commands testdoubleobj] != {} \
	&& [info commands teststringobj] != {} \
	&& [info commands testobj] != {}}]

::tcltest::testConstraint longIs32bit \
	[expr {int(0x80000000) < 0}]

# Tests for the omnibus TclExecuteByteCode function:

# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
Changes to tests/expr-old.test.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.11.12.2 2002/06/10 05:33:15 wolfsuit 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"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."







|


|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.11.12.3 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import -force ::tcltest::*
}

if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
if $gotT1 {
    test expr-old-34.17 {errors in math functions} {
	list [catch {expr T1(4)} msg] $msg
    } {1 {too many arguments for math function}}
}

test expr-old-36.1 {ExprLooksLikeInt procedure} {
    list [catch {expr 0289} msg] $msg
} {1 {"0289" is an invalid octal number}}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
    set x 0289
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
    list [catch {expr 0289.1} msg] $msg
} {0 289.1}







|
|
|







895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
if $gotT1 {
    test expr-old-34.17 {errors in math functions} {
	list [catch {expr T1(4)} msg] $msg
    } {1 {too many arguments for math function}}
}

test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
    expr 0289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
    set x 0289
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
    list [catch {expr 0289.1} msg] $msg
} {0 289.1}
934
935
936
937
938
939
940






















941
942
943
944
945
946
947
    list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}

# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
    # define a "too large integer"; this one works also for 64bit arith
    set x 665802003400000000000000






















    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}

if {[info commands testexprlong] == {}} {
    puts "This application hasn't been compiled with the \"testexprlong\""
    puts "command, so I can't test Tcl_ExprLong etc."
} else {







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
    list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}

# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
    # define a "too large integer"; this one works also for 64bit arith
    set x 665802003400000000000000
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}

# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
    set x "10;"
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.13 {ExprLooksLikeInt procedure} {
    set x " +"
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.14 {ExprLooksLikeInt procedure} {
    set x "123456789012345678901234567890 "
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
test expr-old-36.15 {ExprLooksLikeInt procedure} {
    set x "099 "
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
    set x " 0xffffffffffffffffffffffffffffffffffffff  "
    list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}

if {[info commands testexprlong] == {}} {
    puts "This application hasn't been compiled with the \"testexprlong\""
    puts "command, so I can't test Tcl_ExprLong etc."
} else {
Changes to tests/expr.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
27
28
29
30
31
32
33
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.12.12.1 2002/02/05 02:22:03 wolfsuit 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"})} {
    set gotT1 0
    puts "This application hasn't been compiled with the \"T1\" and"
    puts "\"T2\" math functions, so I'll skip some of the expr tests."
} else {
    set gotT1 1
}

# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $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
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.12.12.2 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint registeredMathFuncs [expr {
    ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"})





}]

# procedures used below

proc put_hello_char {c} {
    global a
    append a [format %c $c]
    return $c
626
627
628
629
630
631
632
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
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} {
    catch {expr sin(1} msg
    set errorInfo
} {syntax error in expression "sin(1": missing close parenthesis at end of function call
    while compiling
"expr sin(1"}
if $gotT1 {
    test expr-15.7 {CompileMathFuncCall: call registered math function} {
	expr 2*T1()
    } 246
    test expr-15.8 {CompileMathFuncCall: call registered math function} {
	expr T2()*3
    } 1035

    test expr-15.9 {CompileMathFuncCall: call registered math function} {
	expr T3(21, 37)
    } 37
    test expr-15.10 {CompileMathFuncCall: call registered math function} {
	expr T3(21.2, 37)
    } 37.0
    test expr-15.11 {CompileMathFuncCall: call registered math function} {
	expr T3(-21.2, -17.5)
    } -17.5


}













test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
    catch {unset a}
    set a(VALUE) ff15
    set i 123
    if {[expr 0x$a(VALUE)] & 16} {
        set i {}







<
|
|
|
|
|
|
<
|
|
|
|
|
|
|
|
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>







622
623
624
625
626
627
628

629
630
631
632
633
634

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} {
    catch {expr sin(1} msg
    set errorInfo
} {syntax error in expression "sin(1": missing close parenthesis at end of function call
    while compiling
"expr sin(1"}

test expr-15.7 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
    expr 2*T1()
} 246
test expr-15.8 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
    expr T2()*3
} 1035

test expr-15.9 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
    expr T3(21, 37)
} 37
test expr-15.10 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
    expr T3(21.2, 37)
} 37.0
test expr-15.11 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
    expr T3(-21.2, -17.5)
} -17.5
test expr-15.12 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
    expr T3(21, wide(37))
} 37
test expr=15.13 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
    expr T3(wide(21), 37)
} 37
test expr=15.14 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
    expr T3(wide(21), wide(37))
} 37
test expr-15.15 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
    expr T3(21.0, wide(37))
} 37.0
test expr=15.16 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
    expr T3(wide(21), 37.0)
} 37.0

test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
    catch {unset a}
    set a(VALUE) ff15
    set i 123
    if {[expr 0x$a(VALUE)] & 16} {
        set i {}
763
764
765
766
767
768
769































770
771
772
773
774
775
test expr-21.7 	{non-numeric boolean literals} {expr !false} 1
test expr-21.8 	{non-numeric boolean literals} {expr !true } 0
test expr-21.9 	{non-numeric boolean literals} {expr !off  } 1
test expr-21.10 {non-numeric boolean literals} {expr !on   } 0
test expr-21.11 {non-numeric boolean literals} {expr !no   } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes  } 0
































# cleanup
if {[info exists a]} {
    unset a
}
::tcltest::cleanupTests
return







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
test expr-21.7 	{non-numeric boolean literals} {expr !false} 1
test expr-21.8 	{non-numeric boolean literals} {expr !true } 0
test expr-21.9 	{non-numeric boolean literals} {expr !off  } 1
test expr-21.10 {non-numeric boolean literals} {expr !on   } 0
test expr-21.11 {non-numeric boolean literals} {expr !no   } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes  } 0

# Test for non-numeric float handling.
#
# These are non-portable because strtod()-support for "Inf" and "NaN"
# is so wildly variable.  This sucks...
test expr-22.1 {non-numeric floats} nonPortable {
    list [catch {expr {NaN + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.2 {non-numeric floats} nonPortable {
    list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} nonPortable {
    set nan NaN
    list [catch {expr {$nan + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.4 {non-numeric floats} nonPortable {
    set inf Inf
    list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} nonPortable {
    list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} nonPortable {
    list [catch {expr Inf} msg] $msg
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} nonPortable {
    list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} nonPortable {
    list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}

# cleanup
if {[info exists a]} {
    unset a
}
::tcltest::cleanupTests
return
Changes to tests/fCmd.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.11 2001/09/04 18:06:34 vincentdarley Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]

# Several tests require need to match results against the unix username












|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.11.8.1 2002/08/20 20:25:27 das Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]

# Several tests require need to match results against the unix username
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    set msg [list [catch {file rename tf1 td1} msg] $msg]
    testchmod 755 td1
    set msg
} {1 {error renaming "tf1" to "td1/tf1": permission denied}}
test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} {
    cleanup
    createfile tf1
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
    cleanup
    createfile tf1







|







429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
    file mkdir td1
    testchmod 000 td1
    createfile tf1
    set msg [list [catch {file rename tf1 td1} msg] $msg]
    testchmod 755 td1
    set msg
} {1 {error renaming "tf1" to "td1/tf1": permission denied}}
test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {pcOnly 95} {
    cleanup
    createfile tf1
    list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
    cleanup
    createfile tf1
540
541
542
543
544
545
546
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
    file rename tf1 /tmp
    glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1
    set msg 
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]

    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir td2
    file mkdir ~/td1
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1]

    set msg [list [catch {file copy td2 ~/td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
    file delete -force ~/td1
    set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]

    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]

    file delete -force ~/td1
    set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    list [catch {file rename -force td1 /tmp} msg] $msg
} {1 {error renaming "td1" to "/tmp/td1": file already exists}}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2/td3 
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    exec chmod 755 td1/td2/td3 
    set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file rename td1 /tmp







|

|






|
>

|








|
>

|







|
>

<
>















|

|







540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581

582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
    file rename tf1 /tmp
    glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file attributes td1 -permissions 0000
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    file attributes td1 -permissions 0755
    set msg 
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    set td1name [file join [file dirname ~] [file tail ~] td1]
    file attributes $td1name -permissions 0000
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]
    file attributes $td1name -permissions 0755
    file delete -force ~/td1
    set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir td2
    file mkdir ~/td1
    set td1name [file join [file dirname ~] [file tail ~] td1]
    file attributes $td1name -permissions 0000
    set msg [list [catch {file copy td2 ~/td1} msg] $msg]
    file attributes $td1name -permissions 0755
    file delete -force ~/td1
    set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \
	{unixOnly notRoot} {
    cleanup
    file mkdir ~/td1/td2
    set td2name [file join [file dirname ~] [file tail ~] td1 td2]
    file attributes $td2name -permissions 0000
    set msg [list [catch {file copy ~/td1 td1} msg] $msg]

    file attributes $td2name -permissions 0755
    file delete -force ~/td1
    set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file mkdir /tmp/td1
    createfile /tmp/td1/tf1
    list [catch {file rename -force td1 /tmp} msg] $msg
} {1 {error renaming "td1" to "/tmp/td1": file already exists}}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file attributes td1/td2/td3 -permissions 0000
    set msg [list [catch {file rename td1 /tmp} msg] $msg]
    file attributes td1/td2/td3 -permissions 0755
    set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \
	{unixOnly notRoot xdev} {
    cleanup /tmp
    file mkdir td1/td2/td3
    file rename td1 /tmp
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
    set result
} {1}

test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/dir
    exec chmod 555 tfa
    set result [catch {file rename tfa/dir tfa2}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}


test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} {
    catch {file delete -force -- tfa /tmp/tfa}







|

|







1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
    set result
} {1}

test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/dir
    file attributes tfa -permissions 0555
    set result [catch {file rename tfa/dir tfa2}]
    file attributes tfa -permissions 0777
    file delete -force tfa
    set result
} {1}


test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} {
    catch {file delete -force -- tfa /tmp/tfa}
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
    file delete -force tfa tfa2
    set result
} {1}

test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/dir/a/b/c
    exec chmod 000 tfa/dir
    set r1 [catch {file copy tfa tfa2}]
    exec chmod 777 tfa/dir
    set result $r1
    file delete -force tfa tfa2
    set result
} {1}

#
# Coverage tests for TclMkdirCmd()







|

|







1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
    file delete -force tfa tfa2
    set result
} {1}

test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/dir/a/b/c
    file attributes tfa/dir -permissions 0000
    set r1 [catch {file copy tfa tfa2}]
    file attributes tfa/dir -permissions 0777
    set result $r1
    file delete -force tfa tfa2
    set result
} {1}

#
# Coverage tests for TclMkdirCmd()
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
    set result
} {1}

test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/file
    exec chmod 000 tfa
    set result [catch {file mkdir tfa/file}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \
	{notRoot} {
    catch {file delete -force -- tfa}







|

|







1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
    set result
} {1}

test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/file
    file attributes tfa -permissions 0000
    set result [catch {file mkdir tfa/file}]
    file attributes tfa -permissions 0777
    file delete -force tfa
    set result
} {1}

test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \
	{notRoot} {
    catch {file delete -force -- tfa}
1441
1442
1443
1444
1445
1446
1447
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
    set result [file isdir tfa]
    file delete tfa
    set result
} {1}


# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 { test the -- argument } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -- tfa
    file exists tfa
} {0}

test fCmd-16.2 { test the -force and -- arguments } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -force -- tfa
    file exists tfa
} {0}

test fCmd-16.3 { test bad option } {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    set result [catch {file delete -dog tfa}]
    file delete tfa
    set result
} {1}

test fCmd-16.4 { test not enough args } {notRoot} {
    catch {file delete}
} {1}

test fCmd-16.5 { test not enough args with options } {notRoot} {
    catch {file delete --}
} {1}

test fCmd-16.6 {delete: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)







|






|






|







|



|







1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
    set result [file isdir tfa]
    file delete tfa
    set result
} {1}


# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 {test the -- argument} {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -- tfa
    file exists tfa
} {0}

test fCmd-16.2 {test the -force and -- arguments} {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    file delete -force -- tfa
    file exists tfa
} {0}

test fCmd-16.3 {test bad option} {notRoot} {
    catch {file delete -force -- tfa}
    createfile tfa
    set result [catch {file delete -dog tfa}]
    file delete tfa
    set result
} {1}

test fCmd-16.4 {test not enough args} {notRoot} {
    catch {file delete}
} {1}

test fCmd-16.5 {test not enough args with options} {notRoot} {
    catch {file delete --}
} {1}

test fCmd-16.6 {delete: source filename translation failing} {notRoot} {
    global env
    set temp $env(HOME)
    unset env(HOME)
1502
1503
1504
1505
1506
1507
1508
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
    set result
} {1}

test fCmd-16.9 {error while deleting file } {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    exec chmod 555 tfa
    set result [catch  {file delete tfa/a }]
    #######
    #######  If any directory in a tree that is being removed does not 
    #######  have write permission, the process will fail!
    #######  This is also the case with "rm -rf"
    #######
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-16.10 {deleting multiple files} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    createfile tfa1
    createfile tfa2
    file delete tfa1 tfa2
    expr ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {notRoot} {
    catch {file delete -force -- tfa}
    file delete tfa
    set result 1
} {1}

# More coverage tests for mkpath()
 test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} {
     catch {file delete -force -- tfa1}
     file mkdir tfa1
     exec chmod 555 tfa1
     set result [catch {file mkdir tfa1/tfa2}]
     exec chmod 777 tfa1
     file delete -force tfa1
     set result
} {1}

test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b







|






|












|









|

|







1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
    set result
} {1}

test fCmd-16.9 {error while deleting file } {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    createfile tfa/a
    file attributes tfa -permissions 0555
    set result [catch  {file delete tfa/a }]
    #######
    #######  If any directory in a tree that is being removed does not 
    #######  have write permission, the process will fail!
    #######  This is also the case with "rm -rf"
    #######
    file attributes tfa -permissions 0777
    file delete -force tfa
    set result
} {1}

test fCmd-16.10 {deleting multiple files} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    createfile tfa1
    createfile tfa2
    file delete tfa1 tfa2
    expr ![file exists tfa1] && ![file exists tfa2]
} {1}

test fCmd-16.11 {TclFileDeleteCmd: removing a nonexistant file} {notRoot} {
    catch {file delete -force -- tfa}
    file delete tfa
    set result 1
} {1}

# More coverage tests for mkpath()
 test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} {
     catch {file delete -force -- tfa1}
     file mkdir tfa1
     file attributes tfa1 -permissions 0555
     set result [catch {file mkdir tfa1/tfa2}]
     file attributes tfa1 -permissions 0777
     file delete -force tfa1
     set result
} {1}

test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa/a/b
1690
1691
1692
1693
1694
1695
1696
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
} {1}

test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    set s [createfile tfa1]
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1
    exec ln -s tfa1 tfa2
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr { $t == "link" }]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1/a/b/c/d
    file mkdir tfa2
    set f [file join [pwd] tfa1/a/b] 
    set f2 [file join [pwd] {tfa2/b alias}]
    exec ln -s $f $f2
    file rename {tfa2/b alias/c} tfa3
    set r1 [file isdir tfa3]
    set r2 [file exists tfa1/a/b/c]
    set result [expr $r1 && !$r2]
    file delete -force tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfalink}
	
    file mkdir tfa1
    set s [createfile tfa2]
    exec ln -s tfa1 tfalink

    file rename tfa2 tfalink
    set result [checkcontent tfa1/tfa2 $s ]
    file delete -force tfa1 tfalink
    set result
} {1}

test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfalink}
	
    file mkdir tfa1
    exec ln -s tfa1 tfalink
    file delete tfa1 
    file rename tfalink tfa2
    set result [expr [string compare [file type tfa2] "link"] == 0]
    file delete tfa2
    set result
} {1}


#
# Coverage tests for TclUnixRmdir
#
test fCmd-19.1 { remove empty directory } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file delete tfa
    file exists tfa
} {0}

test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 555 tfa
    set result [catch {file delete tfa/a}]
    exec chmod 777 tfa
    file delete -force tfa
    set result
} {1}

test fCmd-19.3 { recursive remove } {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file delete -force tfa
    file exists tfa
} {0}








|


|









|


|












|














|











|











|






|



|

|




|







1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
} {1}

test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    set s [createfile tfa1]
    file link -symbolic tfa2 tfa1
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr {$t eq "link"}]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1
    file link -symbolic tfa2 tfa1
    file rename tfa2 tfa3
    set t [file type tfa3]
    set result [expr {$t eq "link"}]
    file delete tfa1 tfa3
    set result
} {1}

test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfa3}
	
    file mkdir tfa1/a/b/c/d
    file mkdir tfa2
    set f [file join [pwd] tfa1/a/b] 
    set f2 [file join [pwd] {tfa2/b alias}]
    file link -symbolic $f2 $f
    file rename {tfa2/b alias/c} tfa3
    set r1 [file isdir tfa3]
    set r2 [file exists tfa1/a/b/c]
    set result [expr $r1 && !$r2]
    file delete -force tfa1 tfa2 tfa3
    set result
} {1}

test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfa2 tfalink}
	
    file mkdir tfa1
    set s [createfile tfa2]
    file link -symbolic tfalink tfa1

    file rename tfa2 tfalink
    set result [checkcontent tfa1/tfa2 $s ]
    file delete -force tfa1 tfalink
    set result
} {1}

test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfa1 tfalink}
	
    file mkdir tfa1
    file link -symbolic tfalink tfa1
    file delete tfa1 
    file rename tfalink tfa2
    set result [expr [string compare [file type tfa2] "link"] == 0]
    file delete tfa2
    set result
} {1}


#
# Coverage tests for TclUnixRmdir
#
test fCmd-19.1 {remove empty directory} {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file delete tfa
    file exists tfa
} {0}

test fCmd-19.2 {rmdir error besides EEXIST} {unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file attributes tfa -permissions 0555
    set result [catch {file delete tfa/a}]
    file attributes tfa -permissions 0777
    file delete -force tfa
    set result
} {1}

test fCmd-19.3 {recursive remove} {notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file delete -force tfa
    file exists tfa
} {0}

1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
#

test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    exec chmod 000 tfa/a
    set result [catch {file delete -force tfa}]
    exec chmod 777 tfa/a
    file delete -force tfa
    set result
} {1}


#
# Feature testing for TclCopyFilesCmd







|

|







1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
#

test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \
	{unixOnly notRoot} {
    catch {file delete -force -- tfa}
    file mkdir tfa
    file mkdir tfa/a
    file attributes tfa/a -permissions 0000
    set result [catch {file delete -force tfa}]
    file attributes tfa/a -permissions 0777
    file delete -force tfa
    set result
} {1}


#
# Feature testing for TclCopyFilesCmd
1878
1879
1880
1881
1882
1883
1884








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
    set r2 [file isdir [file join tfad2 tfad1]]
    set r3 [checkcontent tfa1 $s]
    set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
    file delete -force tfa1 tfad1 tfad2
    set result
} {1}









test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfad1
    file copy tfalink tfalink2
    set result [string match [file type tfalink2] link]
    file delete tfalink tfalink2 
    set result
} {1}

test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} {
    file mkdir tfad1






    exec ln -s tfad1 tfalink





    file copy tfalink tfalink2
    set r1 [file type tfalink]
    set r2 [file type tfalink2]
    set r3 [file isdir tfad1]
    set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]
    file delete tfad1 tfalink tfalink2
    set result
} {1}

test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {
    file mkdir tfad1
    exec ln -s "[pwd]/tfad1" tfad1/tfalink
    file copy tfad1 tfad2
    set result [string match [file type tfad2/tfalink] link]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \







>
>
>
>
>
>
>
>
|

|







|

>
>
>
>
>
>
|
>
>
>
>
>

|
|
|
|
|





|







1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
    set r2 [file isdir [file join tfad2 tfad1]]
    set r3 [checkcontent tfa1 $s]
    set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
    file delete -force tfa1 tfad1 tfad2
    set result
} {1}

test fCmd-21.7.1 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot dontCopyLinks} {
    file mkdir tfad1
    file link -symbolic tfalink tfad1
    file delete tfad1
    set result [list [catch {file copy tfalink tfalink2} msg] $msg]
    file delete -force tfalink tfalink2 
    set result
} {1 {error copying "tfalink": the target of this link doesn't exist}}
test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
    file mkdir tfad1
    file link -symbolic tfalink tfad1
    file delete tfad1
    file copy tfalink tfalink2
    set result [string match [file type tfalink2] link]
    file delete tfalink tfalink2 
    set result
} {1}

test fCmd-21.8.1 {TclCopyFilesCmd: copy a link } {unixOnly notRoot dontCopyLinks} {
    file mkdir tfad1
    file link -symbolic tfalink tfad1
    file copy tfalink tfalink2
    set r1 [file type tfalink]; # link
    set r2 [file type tfalink2]; # directory
    set r3 [file isdir tfad1]; # 1
    set result [expr {("$r1" == "link") && ("$r2" == "directory") && $r3}]
    file delete -force tfad1 tfalink tfalink2
    set result
} {1}
test fCmd-21.8.2 {TclCopyFilesCmd: copy a link } {unixOnly notRoot} {
    file mkdir tfad1
    file link -symbolic tfalink tfad1
    file copy tfalink tfalink2
    set r1 [file type tfalink]; # link
    set r2 [file type tfalink2]; # link
    set r3 [file isdir tfad1]; # 1
    set result [expr {("$r1" == "link") && ("$r2" == "link") && $r3}]
    file delete -force tfad1 tfalink tfalink2
    set result
} {1}

test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {
    file mkdir tfad1
    file link -symbolic tfad1/tfalink "[pwd]/tfad1"
    file copy tfad1 tfad2
    set result [string match [file type tfad2/tfalink] link]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}
   
#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]







|







1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
    catch {file delete -force -- tfa tfad}
    file mkdir tfa [file join tfad tfa file]
    set r1 [catch {file copy -force tfa tfad}]
    set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
    file delete -force tfa tfad
    set result
} {1}

#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} {
    catch {file delete -force -- tfa1 tfa2}
    set s [createfile tfa1]
    set s2 [createfile tfa2 q]
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
    set s [createfile tfa1]	
    file rename -force tfa1 tfa1
    set result [checkcontent tfa1 $s]
    file delete tfa1 
    set result
} {1}

test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad d1]
    set r1 [catch {file rename d1 tfad}]
    set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
    file delete -force d1 tfad
    set result
} {1}







|







1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
    set s [createfile tfa1]	
    file rename -force tfa1 tfa1
    set result [checkcontent tfa1 $s]
    file delete tfa1 
    set result
} {1}

test fCmd-22.3 {TclpRenameFile: rename dir to existing dir} {notRoot} {
    catch {file delete -force -- d1 tfad}
    file mkdir d1 [file join tfad d1]
    set r1 [catch {file rename d1 tfad}]
    set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
    file delete -force d1 tfad
    set result
} {1}
2032
2033
2034
2035
2036
2037
2038
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
    file exists tfa1
} {0}

#
# TclMacCopyDirectory
# Error cases are not covered.
#
test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 a b c]
    file copy tfad1 tfad2
    set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file copy tfad1 tfad2
    set result [expr [file isdir tfad1] && [file isdir tfad2]]
    file delete tfad1 tfad2
    set result
} {1}

test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \
	{notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 x y z]
    file mkdir [file join tfad2 dir]
    file copy tfad1 [file join tfad2 dir]
    set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
    file delete -force tfad1 tfad2
    set result
} {1}

#
# Functionality tests for TclDeleteFilesCmd
#

test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfalink
    file delete tfalink

    set r1 [file isdir tfad1]
    set r2 [file exists tfalink]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file mkdir tfad2
    exec ln -s tfad1 [file join tfad2 link]
    file delete -force tfad2

    set r1 [file isdir tfad1]
    set r2 [file exists tfad2]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    exec ln -s tfad1 tfad2
    file delete tfad1
    file delete tfad2

    set r1 [file exists tfad1]
    set r2 [file exists tfad2]
    
    set result [expr !$r1 && !$r2]







<
|









|
<









|
<














|



|










|




|










|



|







2054
2055
2056
2057
2058
2059
2060

2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071

2072
2073
2074
2075
2076
2077
2078
2079
2080
2081

2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
    file exists tfa1
} {0}

#
# TclMacCopyDirectory
# Error cases are not covered.
#

test fCmd-25.1 {TclMacCopyDirectory: copying a normal directory} {notRoot notFileSharing} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 a b c]
    file copy tfad1 tfad2
    set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
    file delete -force tfad1 tfad2
    set result
} {1}

test fCmd-25.2 {TclMacCopyDirectory: copying a short path normal directory} {notRoot notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file copy tfad1 tfad2
    set result [expr [file isdir tfad1] && [file isdir tfad2]]
    file delete tfad1 tfad2
    set result
} {1}

test fCmd-25.3 {TclMacCopyDirectory: copying dirs between different dirs} {notRoot notFileSharing} {

    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir [file join tfad1 x y z]
    file mkdir [file join tfad2 dir]
    file copy tfad1 [file join tfad2 dir]
    set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
    file delete -force tfad1 tfad2
    set result
} {1}

#
# Functionality tests for TclDeleteFilesCmd
#

test fCmd-26.1 {TclDeleteFilesCmd: delete symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file link -symbolic tfalink tfad1
    file delete tfalink

    set r1 [file isdir tfad1]
    set r2 [file exists tfalink]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.2 {TclDeleteFilesCmd: delete dir with symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file mkdir tfad2
    file link -symbolic [file join tfad2 link] tfad1
    file delete -force tfad2

    set r1 [file isdir tfad1]
    set r2 [file exists tfad2]
    
    set result [expr $r1 && !$r2]
    file delete tfad1
    set result
} {1}

test fCmd-26.3 {TclDeleteFilesCmd: delete dangling symlink} {unixOnly notRoot} {
    catch {file delete -force -- tfad1 tfad2}
		
    file mkdir tfad1
    file link -symbolic tfad2 tfad1
    file delete tfad1
    file delete tfad2

    set r1 [file exists tfad1]
    set r2 [file exists tfad2]
    
    set result [expr !$r1 && !$r2]
2136
2137
2138
2139
2140
2141
2142
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
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}

# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
if {$tcl_platform(platform) == "unix"} {
    set ::tcltest::testConstraints(foundGroup) 0
    catch {
	set groupList [exec groups]
	set group [lindex $groupList 0]
	set ::tcltest::testConstraints(foundGroup) 1
    }
} else {
    set ::tcltest::testConstraints(foundGroup) 1
}

test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}






































































































































































































# cleanup
cleanup
::tcltest::cleanupTests
return



















|



|


|















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




<
<
<
<
<
<
<
<
<
<
<
<
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385












    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}

# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
if {$tcl_platform(platform) == "unix"} {
    ::tcltest::testConstraint foundGroup 0
    catch {
	set groupList [exec groups]
	set group [lindex $groupList 0]
	::tcltest::testConstraint foundGroup 1
    }
} else {
    ::tcltest::testConstraint foundGroup 1
}

test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} {
    catch {file delete -force -- foo.tmp}
    createfile foo.tmp
    set attrs [file attributes foo.tmp]
    list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}

if {[string equal $tcl_platform(platform) "windows"]} {
    if {[string index $tcl_platform(osVersion) 0] >= 5 \
      && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
	tcltest::testConstraint linkDirectory 1
	tcltest::testConstraint linkFile 1
    } else {
	tcltest::testConstraint linkDirectory 0
	tcltest::testConstraint linkFile 0
    }
} else {
    tcltest::testConstraint linkFile 1
    tcltest::testConstraint linkDirectory 1
}

test fCmd-28.1 {file link} {
    list [catch {file link} msg] $msg
} {1 {wrong # args: should be "file link ?-linktype? linkname ?target?"}}

test fCmd-28.2 {file link} {
    list [catch {file link a b c d} msg] $msg
} {1 {wrong # args: should be "file link ?-linktype? linkname ?target?"}}

test fCmd-28.3 {file link} {
    list [catch {file link abc b c} msg] $msg
} {1 {bad switch "abc": must be -symbolic or -hard}}

test fCmd-28.4 {file link} {
    list [catch {file link -abc b c} msg] $msg
} {1 {bad switch "-abc": must be -symbolic or -hard}}

makeDirectory abc.dir
makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file

cd [temporaryDirectory]
test fCmd-28.5 {file link: source already exists} {linkDirectory} {
    cd [temporaryDirectory]
    set res [list [catch {file link abc.dir abc2.dir} msg] $msg]
    cd [workingDirectory]
    set res
} {1 {could not create new link "abc.dir": that path already exists}}

test fCmd-28.6 {file link: unsupported operation} {linkDirectory macOrWin} {
    cd [temporaryDirectory]
    set res [list [catch {file link -hard abc.link abc.dir} msg] $msg]
    cd [workingDirectory]
    set res
} {1 {could not create new link "abc.link" pointing to "abc.dir": illegal operation on a directory}}

test fCmd-28.7 {file link: source already exists} {linkFile} {
    cd [temporaryDirectory]
    set res [list [catch {file link abc.file abc2.file} msg] $msg]
    cd [workingDirectory]
    set res
} {1 {could not create new link "abc.file": that path already exists}}

test fCmd-28.8 {file link} {linkFile winOnly} {
    cd [temporaryDirectory]
    set res [list [catch {file link -symbolic abc.link abc.file} msg] $msg]
    cd [workingDirectory]
    set res
} {1 {could not create new link "abc.link" pointing to "abc.file": not a directory}}

test fCmd-28.9 {file link: success with file} {linkFile} {
    cd [temporaryDirectory]
    file delete -force abc.link
    set res [list [catch {file link abc.link abc.file} msg] $msg]
    cd [workingDirectory]
    set res
} {0 abc.file}

cd [temporaryDirectory]
catch {file delete -force abc.link}
cd [workingDirectory]

test fCmd-28.10 {file link: linking to nonexistent path} {linkDirectory} {
    cd [temporaryDirectory]
    file delete -force abc.link
    set res [list [catch {file link abc.link abc2.doesnt} msg] $msg]
    cd [workingDirectory]
    set res
} {1 {could not create new link "abc.link" since target "abc2.doesnt" doesn't exist}}

test fCmd-28.11 {file link: success with directory} {linkDirectory} {
    cd [temporaryDirectory]
    file delete -force abc.link
    set res [list [catch {file link abc.link abc.dir} msg] $msg]
    cd [workingDirectory]
    set res
} {0 abc.dir}

test fCmd-28.12 {file link: cd into a link} {linkDirectory} {
    cd [temporaryDirectory]
    file delete -force abc.link
    file link abc.link abc.dir
    set orig [pwd]
    cd abc.link
    set dir [pwd]
    cd ..
    set up [pwd]
    cd $orig
    # now '$up' should be either $orig or [file dirname abc.dir],
    # depending on whether 'cd' actually moves to the destination
    # of a link, or simply treats the link as a directory.
    # (on windows the former, on unix the latter, I believe)
    if {([file normalize $up] != [file normalize $orig]) \
      && ([file normalize $up] != [file normalize [file dirname abc.dir]])} {
	set res "wrong directory with 'cd $link ; cd ..'"
    } else {
	set res "ok"
    }
    cd [workingDirectory]
    set res
} {ok}

test fCmd-28.13 {file link} {linkDirectory} {
    # duplicate link throws error
    cd [temporaryDirectory]
    set res [list [catch {file link abc.link abc.dir} msg] $msg]
    cd [workingDirectory]
    set res
} {1 {could not create new link "abc.link": that path already exists}}

test fCmd-28.14 {file link: deletes link not dir} {linkDirectory} {
    cd [temporaryDirectory]
    file delete -force abc.link
    set res [list [file exists abc.link] [file exists abc.dir]]
    cd [workingDirectory]
    set res
} {0 1}

test fCmd-28.15.1 {file link: copies link not dir} {linkDirectory dontCopyLinks} {
    cd [temporaryDirectory]
    file delete -force abc.link
    file link abc.link abc.dir
    file copy abc.link abc2.link
    # abc2.linkdir was a copy of a link to a dir, so it should end up as
    # a directory, not a link (links trace to endpoint).
    set res [list [file type abc2.link] [file tail [file link abc.link]]]
    cd [workingDirectory]
    set res
} {directory abc.dir}
test fCmd-28.15.2 {file link: copies link not dir} {linkDirectory} {
    cd [temporaryDirectory]
    file delete -force abc.link
    file link abc.link abc.dir
    file copy abc.link abc2.link
    set res [list [file type abc2.link] [file tail [file link abc2.link]]]
    cd [workingDirectory]
    set res
} {link abc.dir}

cd [temporaryDirectory]
file delete -force abc.link
file delete -force abc2.link

file copy abc.file abc.dir
file copy abc2.file abc.dir
cd [workingDirectory]

test fCmd-28.16 {file link: glob inside link} {linkDirectory} {
    cd [temporaryDirectory]
    file delete -force abc.link
    file link abc.link abc.dir
    set res [glob -dir abc.link -tails *]
    cd [workingDirectory]
    set res
} {abc.file abc2.file}

test fCmd-28.17 {file link: glob -type l} {linkDirectory} {
    cd [temporaryDirectory]
    set res [glob -dir [pwd] -type l -tails abc*]
    cd [workingDirectory]
    set res
} {abc.link}

test fCmd-28.18 {file link: glob -type d} {linkDirectory} {
    cd [temporaryDirectory]
    set res [lsort [glob -dir [pwd] -type d -tails abc*]]
    cd [workingDirectory]
    set res
} [lsort [list abc.link abc.dir abc2.dir]]

test fCmd-29.1 {weird memory corruption fault} {
    catch {set res [open [file join ~a_totally_bogus_user_id/foo bar]]}
} 1

cd [temporaryDirectory]
file delete -force abc.link
cd [workingDirectory]

removeFile abc2.file
removeFile abc.file
removeDirectory abc2.dir
removeDirectory abc.dir

# cleanup
cleanup
::tcltest::cleanupTests
return












Changes to tests/fileName.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.14.8.2 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.14.8.3 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
308
309
310
311
312
313
314

315
316
317
318
319
320
321
if {[tcltest::testConstraint testsetplatform]} {
    testsetplatform $platform
}

test filename-4.19 {Tcl_SplitPath} {
    set oldDir [pwd]
    set res [catch {

	file mkdir tildetmp
	set nastydir [file join tildetmp ./~tilde]
	file mkdir $nastydir
	set norm [file normalize $nastydir]
	cd tildetmp
	cd ./~tilde
	glob -nocomplain *







>







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
if {[tcltest::testConstraint testsetplatform]} {
    testsetplatform $platform
}

test filename-4.19 {Tcl_SplitPath} {
    set oldDir [pwd]
    set res [catch {
	cd [temporaryDirectory]
	file mkdir tildetmp
	set nastydir [file join tildetmp ./~tilde]
	file mkdir $nastydir
	set norm [file normalize $nastydir]
	cd tildetmp
	cd ./~tilde
	glob -nocomplain *
1121
1122
1123
1124
1125
1126
1127

1128

1129
1130
1131
1132
1133
1134
1135
    testsetplatform $platform
}

test filename-11.13 {Tcl_GlobCmd} {
    list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]


set oldhome $env(HOME)

set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
close [open globTest/x1.c w]







>

>







1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
    testsetplatform $platform
}

test filename-11.13 {Tcl_GlobCmd} {
    list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]

set oldpwd [pwd]
set oldhome $env(HOME)
cd [temporaryDirectory]
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
close [open globTest/x1.c w]
1168
1169
1170
1171
1172
1173
1174










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
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
        [file join $globname .1]\
	[file join $globname a3]\
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
	[file join $globname x1.c]\
	[file join $globname y1.c] [file join $globname z1.c]]]]










test filename-11.17.2 {Tcl_GlobCmd} {unixOnly notRoot} {
    set dir [pwd]
    set ret "error in test"
    if {[catch {
	cd $globname
	exec ln -s a1 link
	cd $dir
	set ret [list [catch {
	    lsort [glob -directory $globname -join * b1]
	} msg] $msg]
    }]} {
	cd $dir
    }
    file delete [file join $globname link]
    set ret
} [list 0 [lsort [list [file join $globname a1 b1] \
  [file join $globname link b1]]]]
# Simpler version of the above test to illustrate a given bug.
test filename-11.17.3 {Tcl_GlobCmd} {unixOnly notRoot} {
    set dir [pwd]
    set ret "error in test"
    if {[catch {
	cd $globname
	exec ln -s a1 link
	cd $dir
	set ret [list [catch {
	    lsort [glob -directory $globname -type d *]
	} msg] $msg]
    }]} {
	cd $dir
    }
    file delete [file join $globname link]
    set ret
} [list 0 [lsort [list [file join $globname a1] \
  [file join $globname a2] \
  [file join $globname a3] \
  [file join $globname link]]]]
# Make sure the bugfix isn't too simple.  We don't want
# to break 'glob -type l'.
test filename-11.17.4 {Tcl_GlobCmd} {unixOnly notRoot} {
    set dir [pwd]
    set ret "error in test"
    if {[catch {
	cd $globname
	exec ln -s a1 link
	cd $dir
	set ret [list [catch {
	    lsort [glob -directory $globname -type l *]
	} msg] $msg]
    }]} {
	cd $dir
    }







>
>
>
>
>
>
>
>
>
>
|




|












|




|















|




|







1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
        [file join $globname .1]\
	[file join $globname a3]\
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
	[file join $globname x1.c]\
	[file join $globname y1.c] [file join $globname z1.c]]]]
if {[string equal $tcl_platform(platform) "windows"]} {
    if {[string index $tcl_platform(osVersion) 0] >= 5 \
      && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
	tcltest::testConstraint linkDirectory 1
    } else {
	tcltest::testConstraint linkDirectory 0
    }
} else {
    tcltest::testConstraint linkDirectory 1
}
test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} {
    set dir [pwd]
    set ret "error in test"
    if {[catch {
	cd $globname
	file link -symbolic link a1
	cd $dir
	set ret [list [catch {
	    lsort [glob -directory $globname -join * b1]
	} msg] $msg]
    }]} {
	cd $dir
    }
    file delete [file join $globname link]
    set ret
} [list 0 [lsort [list [file join $globname a1 b1] \
  [file join $globname link b1]]]]
# Simpler version of the above test to illustrate a given bug.
test filename-11.17.3 {Tcl_GlobCmd} {notRoot linkDirectory} {
    set dir [pwd]
    set ret "error in test"
    if {[catch {
	cd $globname
	file link -symbolic link a1
	cd $dir
	set ret [list [catch {
	    lsort [glob -directory $globname -type d *]
	} msg] $msg]
    }]} {
	cd $dir
    }
    file delete [file join $globname link]
    set ret
} [list 0 [lsort [list [file join $globname a1] \
  [file join $globname a2] \
  [file join $globname a3] \
  [file join $globname link]]]]
# Make sure the bugfix isn't too simple.  We don't want
# to break 'glob -type l'.
test filename-11.17.4 {Tcl_GlobCmd} {notRoot linkDirectory} {
    set dir [pwd]
    set ret "error in test"
    if {[catch {
	cd $globname
	file link -symbolic link a1
	cd $dir
	set ret [list [catch {
	    lsort [glob -directory $globname -type l *]
	} msg] $msg]
    }]} {
	cd $dir
    }
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
    list [catch {glob -types hidden {}} msg] $msg
} {1 {no files matched glob pattern ""}}
test filename-12.3 {simple globbing} {
    list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}

if {$tcl_platform(platform) == "macintosh"} {
  set globPreResult :globTest:
} else {
  set globPreResult globTest/
}
set x1 x1.c
set y1 y1.c
test filename-12.4 {simple globbing} {unixOrPc} {
    lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {







|

|







1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
    list [catch {glob -types hidden {}} msg] $msg
} {1 {no files matched glob pattern ""}}
test filename-12.3 {simple globbing} {
    list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}

if {$tcl_platform(platform) == "macintosh"} {
    set globPreResult :globTest:
} else {
    set globPreResult globTest/
}
set x1 x1.c
set y1 y1.c
test filename-12.4 {simple globbing} {unixOrPc} {
    lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
1578
1579
1580
1581
1582
1583
1584







1585
1586
1587
1588
1589
1590






1591
1592
1593
1594
1595
1596
1597
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}







test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}






test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} {
    lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {







>
>
>
>
>
>
>






>
>
>
>
>
>







1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}

# The current directory could be anywhere; do this to stop spurious matches
file mkdir globTestContext
file rename globTest [file join globTestContext globTest]
set savepwd [pwd]
cd globTestContext

test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
    lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
    lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}

# Reset to where we were
cd $savepwd
file rename [file join globTestContext globTest] globTest
file delete globTestContext

test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} {
    lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} {
    lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699

unset globname

# The following tests are only valid for Unix systems.
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.

catch {exec chmod 000 globTest/a1}
test filename-15.1 {unix specific globbing} {unixOnly nonPortable} {
    string tolower [list [catch {glob globTest/a1/*} msg]  $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable} {
    glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
	{unixOnly nonPortable} {
    # test fails because if an error occur , the interp's result
    # is reset...
    glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}

catch {exec chmod 755 globTest/a1}
test filename-15.4 {unix specific no complain: no errors, good result} \
	{unixOnly nonPortable} {
    # test fails because if an error occurs, the interp's result
    # is reset... or you don't run at scriptics where the
    # outser and welch users exists
    glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}







|













|







1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725

unset globname

# The following tests are only valid for Unix systems.
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.

catch {file attributes globTest/a1 -permissions 0000}
test filename-15.1 {unix specific globbing} {unixOnly nonPortable} {
    string tolower [list [catch {glob globTest/a1/*} msg]  $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable} {
    glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
	{unixOnly nonPortable} {
    # test fails because if an error occur , the interp's result
    # is reset...
    glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}

catch {file attributes globTest/a1 -permissions 0755}
test filename-15.4 {unix specific no complain: no errors, good result} \
	{unixOnly nonPortable} {
    # test fails because if an error occurs, the interp's result
    # is reset... or you don't run at scriptics where the
    # outser and welch users exists
    glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
    global env
    set temp $env(HOME)
    set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
    set result [list [catch {glob ~} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
catch {exec rm -f globTest/odd\\\[\]*?\{\}name}

# The following tests are only valid for Windows systems.
set oldDir [pwd]
if {$::tcltest::testConstraints(pcOnly)} {
    cd c:/
    file delete -force globTest
    file mkdir globTest







|







1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
    global env
    set temp $env(HOME)
    set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
    set result [list [catch {glob ~} msg] $msg]
    set env(HOME) $temp
    set result
} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
catch {file delete -force globTest/odd\\\[\]*?\{\}name}

# The following tests are only valid for Windows systems.
set oldDir [pwd]
if {$::tcltest::testConstraints(pcOnly)} {
    cd c:/
    file delete -force globTest
    file mkdir globTest
1788
1789
1790
1791
1792
1793
1794
1795
1796

1797
1798
1799
1800
1801
1802
1803
1804
} {..}
test filename-16.16 {windows specific globbing} {pcOnly} {
    file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}

# cleanup
catch {file delete -force C:/globTest}
cd $oldDir
file delete -force globTest

set env(HOME) $oldhome
if {[tcltest::testConstraint testsetplatform]} {
    testsetplatform $platform
    catch {unset platform}
}
catch {unset oldhome temp result}
::tcltest::cleanupTests
return







<

>








1814
1815
1816
1817
1818
1819
1820

1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
} {..}
test filename-16.16 {windows specific globbing} {pcOnly} {
    file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}

# cleanup
catch {file delete -force C:/globTest}

file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
if {[tcltest::testConstraint testsetplatform]} {
    testsetplatform $platform
    catch {unset platform}
}
catch {unset oldhome temp result}
::tcltest::cleanupTests
return
Changes to tests/fileSystem.test.
8
9
10
11
12
13
14

15
16
17
18
19
20







21
22
23
24
25
26
27
28
29
30





31

32
33
34
35
36
37
38
39
40
41

42
43
44
45

46
47
48
49

50
51
52
53

54






















55
56

57

58
59

60


61

62
63
64








65








66
67


68
69
70
71
72
73
74
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest
namespace eval ::tcl::test::fileSystem {


    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::makeDirectory
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeDirectory
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test








makeFile "test file" gorp.file
makeDirectory dir.file
makeFile "test file in directory" [file join dir.file inside.file]

# It would be good to be able to make these work on MacOS too.
# If we added 'file link from to' we could easily do that.
catch {exec ln -s gorp.file link.file}
catch {exec ln -s inside.file dir.file/linkinside.file}
catch {exec ln -s dir.file dir.link}







test filesystem-1.0 {link normalisation} {unixOnly} {
   string equal [file normalize gorp.file] [file normalize link.file]
} {0}

test filesystem-1.1 {link normalisation} {unixOnly} {
   string equal [file normalize dir.file] [file normalize dir.link]
} {0}

test filesystem-1.2 {link normalisation} {unixOnly} {
   string equal [file normalize gorp.file/foo] [file normalize link.file/foo]

} {1}

test filesystem-1.3 {link normalisation} {unixOnly} {
   string equal [file normalize dir.file/foo] [file normalize dir.link/foo]

} {1}

test filesystem-1.4 {link normalisation} {unixOnly} {
   string equal [file normalize dir.file/inside.file] [file normalize dir.link/inside.file]

} {1}

test filesystem-1.5 {link normalisation} {unixOnly} {
   string equal [file normalize dir.file/linkinside.file] [file normalize dir.file/linkinside.file]

} {1}























test filesystem-1.6 {link normalisation} {unixOnly} {

   string equal [file normalize dir.file/linkinside.file] [file normalize dir.link/inside.file]

} {0}


test filesystem-1.7 {link normalisation} {unixOnly} {


   string equal [file normalize dir.link/linkinside.file/foo] [file normalize dir.file/inside.file/foo]

} {1}

test filesystem-1.8 {link normalisation} {unixOnly} {








   string equal [file normalize dir.file/linkinside.filefoo] [file normalize dir.link/inside.filefoo]








} {0}



file delete -force link.file dir.link
removeFile [file join dir.file inside.file]
removeDirectory dir.file
removeFile gorp.file

test filesystem-2.0 {new native path} {unixOnly} {
   foreach f [lsort [glob -nocomplain /usr/bin/c*]] {







>
|
|
|
|
|
|
>
>
>
>
>
>
>





|
|
|
|
|
>
>
>
>
>
|
>
|



|



|
|
>


|
|
>


|
|
>


|
|
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|
>
|
>
|

>
|
>
>
|
>


|
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|

>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest
namespace eval ::tcl::test::fileSystem {

    catch {
	namespace import ::tcltest::cleanupTests
	namespace import ::tcltest::makeDirectory
	namespace import ::tcltest::makeFile
	namespace import ::tcltest::removeDirectory
	namespace import ::tcltest::removeFile
	namespace import ::tcltest::test
    }
    
    catch {
	file delete -force link.file
	file delete -force dir.link
	file delete -force [file join dir.file linkinside.file]
    }

makeFile "test file" gorp.file
makeDirectory dir.file
makeFile "test file in directory" [file join dir.file inside.file]

if {[catch {
    file link link.file gorp.file 
    file link \
      [file join dir.file linkinside.file] \
      [file join dir.file inside.file]
    file link dir.link dir.file
}]} {
    tcltest::testConstraint hasLinks 0
} else {
    tcltest::testConstraint hasLinks 1
}

test filesystem-1.0 {link normalisation} {hasLinks} {
   string equal [file normalize gorp.file] [file normalize link.file]
} {0}

test filesystem-1.1 {link normalisation} {hasLinks} {
   string equal [file normalize dir.file] [file normalize dir.link]
} {0}

test filesystem-1.2 {link normalisation} {hasLinks macOrUnix} {
   string equal [file normalize [file join gorp.file foo]] \
     [file normalize [file join link.file foo]]
} {1}

test filesystem-1.3 {link normalisation} {hasLinks} {
   string equal [file normalize [file join dir.file foo]] \
     [file normalize [file join dir.link foo]]
} {1}

test filesystem-1.4 {link normalisation} {hasLinks} {
   string equal [file normalize [file join dir.file inside.file]] \
     [file normalize [file join dir.link inside.file]]
} {1}

test filesystem-1.5 {link normalisation} {hasLinks} {
   string equal [file normalize [file join dir.file linkinside.file]] \
     [file normalize [file join dir.file linkinside.file]]
} {1}

test filesystem-1.6 {link normalisation} {hasLinks} {
   string equal [file normalize [file join dir.file linkinside.file]] \
     [file normalize [file join dir.link inside.file]]
} {0}

test filesystem-1.7 {link normalisation} {hasLinks macOrUnix} {
   string equal [file normalize [file join dir.link linkinside.file foo]] \
     [file normalize [file join dir.file inside.file foo]]
} {1}

test filesystem-1.8 {link normalisation} {hasLinks} {
   string equal [file normalize [file join dir.file linkinside.filefoo]] \
     [file normalize [file join dir.link inside.filefoo]]
} {0}

test filesystem-1.9 {link normalisation} {macOrUnix hasLinks} {
    file delete -force dir.link
    file link dir.link [file nativename dir.file]
    string equal [file normalize [file join dir.file linkinside.file foo]] \
      [file normalize [file join dir.link inside.file foo]]
} {1}

test filesystem-1.10 {link normalisation: double link} {macOrUnix hasLinks} {
    file link dir2.link dir.link
    string equal [file normalize [file join dir.file linkinside.file foo]] \
      [file normalize [file join dir2.link inside.file foo]]
} {1}

makeDirectory dir2.file

test filesystem-1.11 {link normalisation: double link, back in tree} {macOrUnix hasLinks} {
    file link [file join dir2.file dir2.link] dir2.link
    string equal [file normalize [file join dir.file linkinside.file foo]] \
      [file normalize [file join dir2.file dir2.link inside.file foo]]
} {1}

test filesystem-1.12 {file new native path} {} {
    for {set i 0} {$i < 10} {incr i} {
	foreach f [lsort [glob -nocomplain -type l *]] {
	    catch {file readlink $f}
	}
    }
    # If we reach here we've succeeded. We used to crash above.
    expr 1
} {1}

test filesystem-1.13 {file normalisation} {winOnly} {
    # This used to be broken
    file normalize C:/thislongnamedoesntexist
} {C:/thislongnamedoesntexist}

test filesystem-1.14 {file normalisation} {winOnly} {
    # This used to be broken
    file normalize c:/
} {C:/}

file delete -force dir2.file
file delete -force dir2.link
file delete -force link.file dir.link
removeFile [file join dir.file inside.file]
removeDirectory dir.file
removeFile gorp.file

test filesystem-2.0 {new native path} {unixOnly} {
   foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
185
186
187
188
189
190
191
192




































































































































193
194
195
196
197
198
199
200
	set ::env(HOME) /a/b/c
	set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
	set ::env(HOME) $orig
	list $res1 $res2
    }
    -result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}
}
	




































































































































# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}
}

cleanupTests
}
namespace delete ::tcl::test::fileSystem
return







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
	set ::env(HOME) /a/b/c
	set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
	set ::env(HOME) $orig
	list $res1 $res2
    }
    -result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}
}

test filesystem-6.1 {empty file name} {
    list [catch {open ""} msg] $msg
} {1 {couldn't open "": no such file or directory}}

test filesystem-6.2 {empty file name} {
    list [catch {file stat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.3 {empty file name} {
    list [catch {file atime ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.4 {empty file name} {
    list [catch {file attributes ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.5 {empty file name} {
    list [catch {file copy "" ""} msg] $msg
} {1 {error copying "": no such file or directory}}

test filesystem-6.6 {empty file name} {
    list [catch {file delete ""} msg] $msg
} {0 {}}

test filesystem-6.7 {empty file name} {
    list [catch {file dirname ""} msg] $msg
} {0 .}

test filesystem-6.8 {empty file name} {
    list [catch {file executable ""} msg] $msg
} {0 0}

test filesystem-6.9 {empty file name} {
    list [catch {file exists ""} msg] $msg
} {0 0}

test filesystem-6.10 {empty file name} {
    list [catch {file extension ""} msg] $msg
} {0 {}}

test filesystem-6.11 {empty file name} {
    list [catch {file isdirectory ""} msg] $msg
} {0 0}

test filesystem-6.12 {empty file name} {
    list [catch {file isfile ""} msg] $msg
} {0 0}

test filesystem-6.13 {empty file name} {
    list [catch {file join ""} msg] $msg
} {0 {}}

test filesystem-6.14 {empty file name} {
    list [catch {file link ""} msg] $msg
} {1 {could not read link "": no such file or directory}}

test filesystem-6.15 {empty file name} {
    list [catch {file lstat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.16 {empty file name} {
    list [catch {file mtime ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.17 {empty file name} {
    list [catch {file mtime "" 0} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.18 {empty file name} {
    list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}

test filesystem-6.19 {empty file name} {
    list [catch {file nativename ""} msg] $msg
} {0 {}}

test filesystem-6.20 {empty file name} {
    list [catch {file normalize ""} msg] $msg
} {0 {}}

test filesystem-6.21 {empty file name} {
    list [catch {file owned ""} msg] $msg
} {0 0}

test filesystem-6.22 {empty file name} {
    list [catch {file pathtype ""} msg] $msg
} {0 relative}

test filesystem-6.23 {empty file name} {
    list [catch {file readable ""} msg] $msg
} {0 0}

test filesystem-6.24 {empty file name} {
    list [catch {file readlink ""} msg] $msg
} {1 {could not readlink "": no such file or directory}}

test filesystem-6.25 {empty file name} {
    list [catch {file rename "" ""} msg] $msg
} {1 {error renaming "": no such file or directory}}

test filesystem-6.26 {empty file name} {
    list [catch {file rootname ""} msg] $msg
} {0 {}}

test filesystem-6.27 {empty file name} {
    list [catch {file separator ""} msg] $msg
} {1 {Unrecognised path}}

test filesystem-6.28 {empty file name} {
    list [catch {file size ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.29 {empty file name} {
    list [catch {file split ""} msg] $msg
} {0 {}}

test filesystem-6.30 {empty file name} {
    list [catch {file system ""} msg] $msg
} {1 {Unrecognised path}}

test filesystem-6.31 {empty file name} {
    list [catch {file tail ""} msg] $msg
} {0 {}}

test filesystem-6.32 {empty file name} {
    list [catch {file type ""} msg] $msg
} {1 {could not read "": no such file or directory}}

test filesystem-6.33 {empty file name} {
    list [catch {file writable ""} msg] $msg
} {0 0}

# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}
}

cleanupTests
}
namespace delete ::tcl::test::fileSystem
return
Changes to tests/format.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# Commands covered:  format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.9.8.1 2002/06/10 05:33:15 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).












|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# Commands covered:  format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.9.8.2 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# The following code is needed because some versions of SCO Unix have
# a round-off error in sprintf which would cause some of the tests to
# fail.  Someday I hope this code shouldn't be necessary (code added
# 9/9/91).
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
        format {%s} $b    
    } $b
    append b "x"
}

set ::tcltest::testConstraints(64bitInts) \
	[expr {0x80000000 > 0}]
set ::tcltest::testConstraints(wideIntExpressions) \
	[expr {wide(0x80000000) != int(0x80000000)}]

test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
    list [catch {format %d 7810179016327718216} msg] $msg
} {1 {integer value too large to represent}}
test format-17.2 {testing %ld with wide} {64bitInts} {
    format %ld 7810179016327718216







|

|







483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
for {set i 290} {$i < 400} {incr i} {
    test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
        format {%s} $b    
    } $b
    append b "x"
}

::tcltest::testConstraint 64bitInts \
	[expr {0x80000000 > 0}]
::tcltest::testConstraint wideIntExpressions \
	[expr {wide(0x80000000) != int(0x80000000)}]

test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
    list [catch {format %d 7810179016327718216} msg] $msg
} {1 {integer value too large to represent}}
test format-17.2 {testing %ld with wide} {64bitInts} {
    format %ld 7810179016327718216
Changes to tests/http.test.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51


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) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.25 2001/10/12 19:44:56 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[catch {package require http 2} version]} {
    if {[info exist http2]} {
	catch {puts "Cannot load http 2.* package"}
	return
    } else {
	catch {puts "Running http 2.* tests in slave interp"}
	set interp [interp create http2]
	$interp eval [list set http2 "running"]

	$interp eval [list source [info script]]
	interp delete $interp
	return
    }
}

proc bgerror {args} {
    global errorInfo
    puts stderr "http.test bgerror"
    puts stderr [join $args]
    puts stderr $errorInfo
}

set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

# Ensure httpd file exists

set origFile [file join $::tcltest::testsDirectory httpd]
set newFile [file join $::tcltest::workingDirectory httpd]
if {![file exists $newFile]} {


    file copy $origFile $newFile
    set removeHttpd 1
}
set httpdFile [file join $::tcltest::workingDirectory httpd]

if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
    set httpthread [testthread create "
	source $httpdFile
	testthread wait
    "]
    testthread send $httpthread [list set port $port]
    testthread send $httpthread [list set bindata $bindata]
    testthread send $httpthread {httpd_init $port}
    puts "Running httpd in thread $httpthread"
} else {
    if ![file exists $httpdFile] {
	puts "Cannot read $httpdFile script, http test skipped"
	unset port
	return
    }
    source $httpdFile

    if [catch {httpd_init $port} listen] {
	puts "Cannot start http server, http test skipped"
	unset port
	return


    }
}


test http-1.1 {http::config} {
    http::config
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent "Tcl http client package $version"]







|


|











>




















|
|
>
>
|


<



|







|





>
|



>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.25.2.1 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

if {[catch {package require http 2} version]} {
    if {[info exist http2]} {
	catch {puts "Cannot load http 2.* package"}
	return
    } else {
	catch {puts "Running http 2.* tests in slave interp"}
	set interp [interp create http2]
	$interp eval [list set http2 "running"]
	$interp eval [list set argv $argv]
	$interp eval [list source [info script]]
	interp delete $interp
	return
    }
}

proc bgerror {args} {
    global errorInfo
    puts stderr "http.test bgerror"
    puts stderr [join $args]
    puts stderr $errorInfo
}

set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}

# Ensure httpd file exists

set origFile [file join $::tcltest::testsDirectory httpd]
set httpdFile [file join [temporaryDirectory] httpd_[pid]]
if {![file exists $httpdFile]} {
    makeFile "" $httpdFile
    file delete $httpdFile
    file copy $origFile $httpdFile
    set removeHttpd 1
}


if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
    set httpthread [testthread create "
	source [list $httpdFile]
	testthread wait
    "]
    testthread send $httpthread [list set port $port]
    testthread send $httpthread [list set bindata $bindata]
    testthread send $httpthread {httpd_init $port}
    puts "Running httpd in thread $httpthread"
} else {
    if {![file exists $httpdFile]} {
	puts "Cannot read $httpdFile script, http test skipped"
	unset port
	return
    }
    source $httpdFile
    # Let the OS pick the port; that's much more flexible
    if {[catch {httpd_init 0} listen]} {
	puts "Cannot start http server, http test skipped"
	unset port
	return
    } else {
	set port [lindex [fconfigure $listen -sockname] 2]
    }
}


test http-1.1 {http::config} {
    http::config
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -useragent "Tcl http client package $version"]
218
219
220
221
222
223
224
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
    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &
    }
    ::tcltest::makeFile $query outdata
    set fp [open outdata]

    proc asyncCB {token} {
	global postResult
	lappend postResult [http::data $token]
    }
    set postResult [list ]
    set t [http::geturl $posturl -querychannel $fp]
    http::wait $t
    set testRes [list [http::status $t] [string length $query] [http::data $t]]

    # Now do async
    http::cleanup $t
    close $fp
    set fp [open outdata]
    set t [http::geturl $posturl -querychannel $fp -command asyncCB]
    set postResult [list PostStart]
    http::wait $t

    lappend testRes [http::status $t] $postResult

    set testRes
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}

# On Linux platforms when the client and server are on the same
# host, the client is unable to read the server's response one
# it hits the write error.  The status is "eof"

# On Windows, the http::wait procedure gets a
# "connection reset by peer" error while reading the reply

test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
    set query foo=bar
    set sep ""
    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &
    }
    ::tcltest::makeFile $query outdata
    set fp [open outdata]

    proc asyncCB {token} {
	global postResult
	lappend postResult [http::data $token]
    }
    proc postProgress {token x y} {
	global postProgress







|
|













|





>




















|
|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &
    }
    set file [makeFile $query outdata]
    set fp [open $file]

    proc asyncCB {token} {
	global postResult
	lappend postResult [http::data $token]
    }
    set postResult [list ]
    set t [http::geturl $posturl -querychannel $fp]
    http::wait $t
    set testRes [list [http::status $t] [string length $query] [http::data $t]]

    # Now do async
    http::cleanup $t
    close $fp
    set fp [open $file]
    set t [http::geturl $posturl -querychannel $fp -command asyncCB]
    set postResult [list PostStart]
    http::wait $t

    lappend testRes [http::status $t] $postResult
    removeFile outdata
    set testRes
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}

# On Linux platforms when the client and server are on the same
# host, the client is unable to read the server's response one
# it hits the write error.  The status is "eof"

# On Windows, the http::wait procedure gets a
# "connection reset by peer" error while reading the reply

test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
    set query foo=bar
    set sep ""
    set i 0
    # Create about 120K of query data
    while {$i < 14} {
	incr i
	append query $sep$query
	set sep &
    }
    set file [makeFile $query outdata]
    set fp [open $file]

    proc asyncCB {token} {
	global postResult
	lappend postResult [http::data $token]
    }
    proc postProgress {token x y} {
	global postProgress
283
284
285
286
287
288
289

290
291
292
293
294
295
296
	http::wait $t
	upvar #0 $t state
    } err]} {
	puts $errorInfo
	error $err
    }


    list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}

test http-3.13 {http::geturl socket leak test} {
    set chanCount [llength [file channels]]
    for {set i 0} {$i < 3} {incr i} {
	catch {http::geturl $badurl -timeout 5000} 







>







289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
	http::wait $t
	upvar #0 $t state
    } err]} {
	puts $errorInfo
	error $err
    }

    removeFile outdata
    list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}

test http-3.13 {http::geturl socket leak test} {
    set chanCount [llength [file channels]]
    for {set i 0} {$i < 3} {incr i} {
	catch {http::geturl $badurl -timeout 5000} 
316
317
318
319
320
321
322

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

test http-4.3 {http::Event} {
    set token [http::geturl $url]
    http::code $token
} {HTTP/1.0 200 Data follows}

test http-4.4 {http::Event} {

    set out [open testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    set in [open testfile]
    set x [read $in]
    close $in
    file delete testfile
    set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-4.5 {http::Event} {

    set out [open testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    upvar #0 $token data
    file delete testfile
    expr $data(currentsize) == $data(totalsize)
} 1

test http-4.6 {http::Event} {

    set out [open testfile w]
    set token [http::geturl $binurl -channel $out]
    close $out
    set in [open testfile]
    fconfigure $in -translation binary
    set x [read $in]
    close $in
    file delete testfile
    set x
} "$bindata$binurl"

proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"







>
|


|


|







>
|



|




>
|


|



|







323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370

test http-4.3 {http::Event} {
    set token [http::geturl $url]
    http::code $token
} {HTTP/1.0 200 Data follows}

test http-4.4 {http::Event} {
    set testfile [makeFile "" testfile]
    set out [open $testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    set in [open $testfile]
    set x [read $in]
    close $in
    removeFile $testfile
    set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-4.5 {http::Event} {
    set testfile [makeFile "" testfile]
    set out [open $testfile w]
    set token [http::geturl $url -channel $out]
    close $out
    upvar #0 $token data
    removeFile $testfile
    expr $data(currentsize) == $data(totalsize)
} 1

test http-4.6 {http::Event} {
    set testfile [makeFile "" testfile]
    set out [open $testfile w]
    set token [http::geturl $binurl -channel $out]
    close $out
    set in [open $testfile]
    fconfigure $in -translation binary
    set x [read $in]
    close $in
    removeFile $testfile
    set x
} "$bindata$binurl"

proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"
482
483
484
485
486
487
488
489
490
491
492
493
} else {
    close $listen
}

if {[info exist removeHttpd]} {
    removeFile $httpdFile
}
foreach file [list outdata] {
    catch {::tcltest::removeFile $file}
}

::tcltest::cleanupTests







<
<
|
<

492
493
494
495
496
497
498


499

500
} else {
    close $listen
}

if {[info exist removeHttpd]} {
    removeFile $httpdFile
}




::tcltest::cleanupTests
Changes to tests/httpold.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
# Commands covered:  http_config, http_get, http_wait, http_reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: httpold.test,v 1.8 2000/04/10 17:18:59 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
	catch {puts "Cannot load http 1.0 package"}
	::tcltest::cleanupTests
	return
    } else {
	catch {puts "Running http 1.0 tests in slave interp"}
	set interp [interp create httpold]
	$interp eval [list set httpold "running"]

	$interp eval [list source [info script]]
	interp delete $interp
	::tcltest::cleanupTests
	return
    }
}














|















>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
# Commands covered:  http_config, http_get, http_wait, http_reset
#
# This file contains a collection of tests for the http script library.
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: httpold.test,v 1.8.18.1 2002/08/20 20:25:27 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[catch {package require http 1.0}]} {
    if {[info exist httpold]} {
	catch {puts "Cannot load http 1.0 package"}
	::tcltest::cleanupTests
	return
    } else {
	catch {puts "Running http 1.0 tests in slave interp"}
	set interp [interp create httpold]
	$interp eval [list set httpold "running"]
	$interp eval [list set argv $argv]
	$interp eval [list source [info script]]
	interp delete $interp
	::tcltest::cleanupTests
	return
    }
}

46
47
48
49
50
51
52
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
if [catch {httpd_init $port} listen] {
    puts "Cannot start http server, http test skipped"
    unset port
    ::tcltest::cleanupTests
    return
}

test http-1.1 {http_config} {
    http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}

test http-1.2 {http_config} {
    http_config -proxyfilter
} httpProxyRequired

test http-1.3 {http_config} {
    catch {http_config -junk}
} 1

test http-1.4 {http_config} {
    http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
    set x [http_config]
    http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
	-useragent "Tcl http client package 1.0"
    set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}

test http-1.5 {http_config} {
    catch {http_config -proxyhost {} -junk 8080}
} 1

test http-2.1 {http_reset} {
    catch {http_reset http#1}
} 0

test http-3.1 {http_get} {
    catch {http_get -bogus flag}
} 1
test http-3.2 {http_get} {
    catch {http_get http:junk} err
    set err
} {Unsupported URL: http:junk}

set url [info hostname]:$port
test http-3.3 {http_get} {
    set token [http_get $url]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"

set tail /a/b/c
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary

test http-3.4 {http_get} {
    set token [http_get $url]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

proc selfproxy {host} {
    global port
    return [list [info hostname] $port]
}
test http-3.5 {http_get} {
    http_config -proxyfilter selfproxy
    set token [http_get $url]
    http_config -proxyfilter httpProxyRequired
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http://$url</h2>
</body></html>"

test http-3.6 {http_get} {
    http_config -proxyfilter bogus
    set token [http_get $url]
    http_config -proxyfilter httpProxyRequired
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-3.7 {http_get} {
    set token [http_get $url -headers {Pragma no-cache}]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-3.8 {http_get} {
    set token [http_get $url -query Name=Value&Foo=Bar]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
<dl>
<dt>Name<dd>Value
<dt>Foo<dd>Bar
</dl>
</body></html>"

test http-3.9 {http_get} {
    set token [http_get $url -validate 1]
    http_code $token
} "HTTP/1.0 200 OK"


test http-4.1 {httpEvent} {
    set token [http_get $url]
    upvar #0 $token data
    array set meta $data(meta)
    expr ($data(totalsize) == $meta(Content-Length))
} 1

test http-4.2 {httpEvent} {
    set token [http_get $url]
    upvar #0 $token data
    array set meta $data(meta)
    string compare $data(type) [string trim $meta(Content-Type)]
} 0

test http-4.3 {httpEvent} {
    set token [http_get $url]
    http_code $token
} {HTTP/1.0 200 Data follows}

test http-4.4 {httpEvent} {

    set out [open testfile w]
    set token [http_get $url -channel $out]
    close $out
    set in [open testfile]
    set x [read $in]
    close $in
    file delete testfile
    set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test http-4.5 {httpEvent} {

    set out [open testfile w]
    set token [http_get $url -channel $out]
    close $out
    upvar #0 $token data
    file delete testfile
    expr $data(currentsize) == $data(totalsize)
} 1

test http-4.6 {httpEvent} {

    set out [open testfile w]
    set token [http_get $binurl -channel $out]
    close $out
    set in [open testfile]
    fconfigure $in -translation binary
    set x [read $in]
    close $in
    file delete testfile
    set x
} "$bindata$binurl"

proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"
    }
    set progress [list $total $current]
}
if 0 {
    # This test hangs on Windows95 because the client never gets EOF
    set httpLog 1
    test http-4.6 {httpEvent} {
	set token [http_get $url -blocksize 50 -progress myProgress]
	set progress
    } {111 111}
}
test http-4.7 {httpEvent} {
    set token [http_get $url -progress myProgress]
    set progress
} {111 111}
test http-4.8 {httpEvent} {
    set token [http_get $url]
    http_status $token
} {ok}
test http-4.9 {httpEvent} {
    set token [http_get $url -progress myProgress]
    http_code $token
} {HTTP/1.0 200 Data follows}
test http-4.10 {httpEvent} {
    set token [http_get $url -progress myProgress]
    http_size $token
} {111}
test http-4.11 {httpEvent} {
    set token [http_get $url -timeout 1 -command {#}]
    http_reset $token
    http_status $token
} {reset}
test http-4.12 {httpEvent} {
    update
    set x {}
    after 500 {lappend x ok}
    set token [http_get $url -timeout 1 -command {lappend x fail}]
    vwait x
    list [http_status $token] $x
} {timeout ok}

test http-5.1 {http_formatQuery} {
    http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}

test http-5.2 {http_formatQuery} {
    http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}

test http-5.3 {http_formatQuery} {
    http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test http-6.1 {httpProxyRequired} {
    update
    http_config -proxyhost [info hostname] -proxyport $port
    set token [http_get $url]
    http_wait $token
    http_config -proxyhost {} -proxyport {}
    upvar #0 $token data
    set data(body)







|



|



|



|







|



|



|


|





|











|











|









|









|







|












|





|






|






|




|
>
|


|


|






|
>
|



|



|
>
|


|



|













|




|



|



|



|



|




|








|



|



|



|







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
if [catch {httpd_init $port} listen] {
    puts "Cannot start http server, http test skipped"
    unset port
    ::tcltest::cleanupTests
    return
}

test httpold-1.1 {http_config} {
    http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}

test httpold-1.2 {http_config} {
    http_config -proxyfilter
} httpProxyRequired

test httpold-1.3 {http_config} {
    catch {http_config -junk}
} 1

test httpold-1.4 {http_config} {
    http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
    set x [http_config]
    http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
	-useragent "Tcl http client package 1.0"
    set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}

test httpold-1.5 {http_config} {
    catch {http_config -proxyhost {} -junk 8080}
} 1

test httpold-2.1 {http_reset} {
    catch {http_reset http#1}
} 0

test httpold-3.1 {http_get} {
    catch {http_get -bogus flag}
} 1
test httpold-3.2 {http_get} {
    catch {http_get http:junk} err
    set err
} {Unsupported URL: http:junk}

set url [info hostname]:$port
test httpold-3.3 {http_get} {
    set token [http_get $url]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"

set tail /a/b/c
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary

test httpold-3.4 {http_get} {
    set token [http_get $url]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

proc selfproxy {host} {
    global port
    return [list [info hostname] $port]
}
test httpold-3.5 {http_get} {
    http_config -proxyfilter selfproxy
    set token [http_get $url]
    http_config -proxyfilter httpProxyRequired
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http://$url</h2>
</body></html>"

test httpold-3.6 {http_get} {
    http_config -proxyfilter bogus
    set token [http_get $url]
    http_config -proxyfilter httpProxyRequired
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test httpold-3.7 {http_get} {
    set token [http_get $url -headers {Pragma no-cache}]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test httpold-3.8 {http_get} {
    set token [http_get $url -query Name=Value&Foo=Bar]
    http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
<dl>
<dt>Name<dd>Value
<dt>Foo<dd>Bar
</dl>
</body></html>"

test httpold-3.9 {http_get} {
    set token [http_get $url -validate 1]
    http_code $token
} "HTTP/1.0 200 OK"


test httpold-4.1 {httpEvent} {
    set token [http_get $url]
    upvar #0 $token data
    array set meta $data(meta)
    expr ($data(totalsize) == $meta(Content-Length))
} 1

test httpold-4.2 {httpEvent} {
    set token [http_get $url]
    upvar #0 $token data
    array set meta $data(meta)
    string compare $data(type) [string trim $meta(Content-Type)]
} 0

test httpold-4.3 {httpEvent} {
    set token [http_get $url]
    http_code $token
} {HTTP/1.0 200 Data follows}

test httpold-4.4 {httpEvent} {
    set testfile [makeFile "" testfile]
    set out [open $testfile w]
    set token [http_get $url -channel $out]
    close $out
    set in [open $testfile]
    set x [read $in]
    close $in
    removeFile $testfile
    set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"

test httpold-4.5 {httpEvent} {
    set testfile [makeFile "" testfile]
    set out [open $testfile w]
    set token [http_get $url -channel $out]
    close $out
    upvar #0 $token data
    removeFile $testfile
    expr $data(currentsize) == $data(totalsize)
} 1

test httpold-4.6 {httpEvent} {
    set testfile [makeFile "" testfile]
    set out [open $testfile w]
    set token [http_get $binurl -channel $out]
    close $out
    set in [open $testfile]
    fconfigure $in -translation binary
    set x [read $in]
    close $in
    removeFile $testfile
    set x
} "$bindata$binurl"

proc myProgress {token total current} {
    global progress httpLog
    if {[info exists httpLog] && $httpLog} {
	puts "progress $total $current"
    }
    set progress [list $total $current]
}
if 0 {
    # This test hangs on Windows95 because the client never gets EOF
    set httpLog 1
    test httpold-4.6 {httpEvent} {
	set token [http_get $url -blocksize 50 -progress myProgress]
	set progress
    } {111 111}
}
test httpold-4.7 {httpEvent} {
    set token [http_get $url -progress myProgress]
    set progress
} {111 111}
test httpold-4.8 {httpEvent} {
    set token [http_get $url]
    http_status $token
} {ok}
test httpold-4.9 {httpEvent} {
    set token [http_get $url -progress myProgress]
    http_code $token
} {HTTP/1.0 200 Data follows}
test httpold-4.10 {httpEvent} {
    set token [http_get $url -progress myProgress]
    http_size $token
} {111}
test httpold-4.11 {httpEvent} {
    set token [http_get $url -timeout 1 -command {#}]
    http_reset $token
    http_status $token
} {reset}
test httpold-4.12 {httpEvent} {
    update
    set x {}
    after 500 {lappend x ok}
    set token [http_get $url -timeout 1 -command {lappend x fail}]
    vwait x
    list [http_status $token] $x
} {timeout ok}

test httpold-5.1 {http_formatQuery} {
    http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}

test httpold-5.2 {http_formatQuery} {
    http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}

test httpold-5.3 {http_formatQuery} {
    http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}

test httpold-6.1 {httpProxyRequired} {
    update
    http_config -proxyhost [info hostname] -proxyport $port
    set token [http_get $url]
    http_wait $token
    http_config -proxyhost {} -proxyport {}
    upvar #0 $token data
    set data(body)
Changes to tests/info.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.17.10.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.17.10.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Set up namespaces needed to test operation of "info args", "info body",
367
368
369
370
371
372
373


374
375
376
377
378
379
380

test info-12.1 {info locals option} {
    set a 22
    proc t1 {x y} {
        set b 13
        set c testing
        global a


        return [info locals]
    }
    lsort [t1 23 24]
} {b c x y}
test info-12.2 {info locals option} {
    proc t1 {x y} {
        set xx1 2







>
>







367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382

test info-12.1 {info locals option} {
    set a 22
    proc t1 {x y} {
        set b 13
        set c testing
        global a
	global aa
	set aa 23
        return [info locals]
    }
    lsort [t1 23 24]
} {b c x y}
test info-12.2 {info locals option} {
    proc t1 {x y} {
        set xx1 2
515
516
517
518
519
520
521
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

test info-16.1 {info script option} {
    list [catch {info script x x} msg] $msg
} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
    file tail [info sc]
} "info.test"
removeFile gorp.info
makeFile "info script\n" gorp.info
test info-16.3 {info script option} {
    list [source gorp.info] [file tail [info script]]
} [list gorp.info info.test]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} "info.test"
test info-16.6 {info script option} {
    set script [info script]
    list [file tail [info script]] \
	    [info script newname.txt] \
	    [file tail [info script $script]]
} [list info.test newname.txt info.test]
test info-16.7 {info script option} {
    set script [info script]
    info script newname.txt
    list [source gorp.info] [file tail [info script]] \
	    [file tail [info script $script]]
} [list gorp.info newname.txt info.test]
removeFile gorp.info
makeFile {list [info script] [info script foo.bar]} gorp.info
test info-16.3 {info script option} {
    list [source gorp.info] [file tail [info script]]
} [list [list gorp.info foo.bar] info.test]
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {







<
|

|
|

















|

|

|
|
|
|







517
518
519
520
521
522
523

524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559

test info-16.1 {info script option} {
    list [catch {info script x x} msg] $msg
} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
    file tail [info sc]
} "info.test"

set gorpfile [makeFile "info script\n" gorp.info]
test info-16.3 {info script option} {
    list [source $gorpfile] [file tail [info script]]
} [list $gorpfile info.test]
test info-16.4 {resetting "info script" after errors} {
    catch {source ~_nobody_/foo}
    file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
    catch {source _nonexistent_}
    file tail [info script]
} "info.test"
test info-16.6 {info script option} {
    set script [info script]
    list [file tail [info script]] \
	    [info script newname.txt] \
	    [file tail [info script $script]]
} [list info.test newname.txt info.test]
test info-16.7 {info script option} {
    set script [info script]
    info script newname.txt
    list [source $gorpfile] [file tail [info script]] \
	    [file tail [info script $script]]
} [list $gorpfile newname.txt info.test]
removeFile gorp.info
set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
test info-16.8 {info script option} {
    list [source $gorpfile] [file tail [info script]]
} [list [list $gorpfile foo.bar] info.test]
removeFile gorp.info

test info-17.1 {info sharedlibextension option} {
    list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}

test info-18.1 {info tclversion option} {
Changes to tests/interp.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.12.14.2 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The set of hidden commands is platform dependent:












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.12.14.3 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# The set of hidden commands is platform dependent:
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
























295
296
297
298
299
300
301
    a eval bar s1 s2 s3
} {seen in master: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} {
   catch {interp create a}
   list [catch {a alias} msg] $msg
} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}

# Part 8: Testing aliases for non-existent targets
test interp-9.1 {testing aliases for non-existent targets} {
    catch {interp create a}
    a alias zop nonexistent-command-in-master
    list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-master"}}
test interp-9.2 {testing aliases for non-existent targets} {
    catch {interp create a}
    a alias zop nonexistent-command-in-master
    proc nonexistent-command-in-master {} {return i_exist!}
    a eval zop
} i_exist!

























if {[info command nonexistent-command-in-master] != ""} {
    rename nonexistent-command-in-master {}
}

# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {







|











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
    a eval bar s1 s2 s3
} {seen in master: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} {
   catch {interp create a}
   list [catch {a alias} msg] $msg
} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}

# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
    catch {interp create a}
    a alias zop nonexistent-command-in-master
    list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-master"}}
test interp-9.2 {testing aliases for non-existent targets} {
    catch {interp create a}
    a alias zop nonexistent-command-in-master
    proc nonexistent-command-in-master {} {return i_exist!}
    a eval zop
} i_exist!
test interp-9.3 {testing aliases for hidden commands} {
    catch {interp create a}
    a eval {proc p {} {return ENTER_A}}
    interp alias {} p a p
    lappend res [list [catch p msg] $msg]
    interp hide a p
    lappend res [list [catch p msg] $msg]
    rename p {}
    interp delete a
    set res
 } {{0 ENTER_A} {1 {invalid command name "p"}}}
test interp-9.4 {testing aliases and namespace commands} {
    proc p {} {return GLOBAL}
    namespace eval tst {
	proc p {} {return NAMESPACE}
    }
    interp alias {} a {} p
    set res [a]
    lappend res [namespace eval tst a]
    rename p {}
    rename a {}
    namespace delete tst
    set res
 } {GLOBAL GLOBAL}

if {[info command nonexistent-command-in-master] != ""} {
    rename nonexistent-command-in-master {}
}

# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {
477
478
479
480
481
482
483
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
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
    catch {interp delete z}
    interp create z
    z eval close stdout
    list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
catch {removeFile file-15.2}
test interp-15.2 {testing file sharing} {
    catch {interp delete z}
    interp create z
    set f [open file-15.2 w]
    interp share "" $f z
    z eval puts $f hello
    z eval close $f
    close $f
} ""
catch {removeFile file-15.2}

test interp-15.3 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
catch {removeFile file-15.4}
test interp-15.4 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open file-15.4 w]
    interp share "" $f xsafe
    xsafe eval puts $f hello
    xsafe eval close $f
    close $f
} ""
catch {removeFile file-15.4}

test interp-15.5 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    interp share "" stdout xsafe
    list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
catch {removeFile file-15.6}
test interp-15.6 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open file-15.6 w]
    interp share "" $f xsafe
    set x [list [catch [list xsafe eval gets $f] msg] $msg]
    xsafe eval close $f
    close $f
    string compare [string tolower $x] \
		[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
} 0
catch {removeFile file-15.6}
catch {removeFile file-15.7}
test interp-15.7 {testing file transferring} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open file-15.7 w]
    interp transfer "" $f xsafe
    xsafe eval puts $f hello
    xsafe eval close $f
} ""
catch {removeFile file-15.7}
catch {removeFile file-15.8}
test interp-15.8 {testing file transferring} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open file-15.8 w]
    interp transfer "" $f xsafe
    xsafe eval close $f
    set x [list [catch {close $f} msg] $msg]
    string compare [string tolower $x] \
		[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
catch {removeFile file-15.8}


#
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}

test interp-15.9 {testing deletion order} {







<
|


|




|
|
>





<
|


|




|
|
>






<
|


|






|
|
|
|


|



|
|
|
|


|





|
|
>







501
502
503
504
505
506
507

508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523

524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540

541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
    catch {interp delete z}
    interp create z
    z eval close stdout
    list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}

test interp-15.2 {testing file sharing} -body {
    catch {interp delete z}
    interp create z
    set f [open [makeFile {} file-15.2] w]
    interp share "" $f z
    z eval puts $f hello
    z eval close $f
    close $f
} -cleanup {
    removeFile file-15.2
} -result ""
test interp-15.3 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}

test interp-15.4 {testing file sharing} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.4] w]
    interp share "" $f xsafe
    xsafe eval puts $f hello
    xsafe eval close $f
    close $f
} -cleanup {
    removeFile file-15.4
} -result ""
test interp-15.5 {testing file sharing} {
    catch {interp delete xsafe}
    interp create xsafe -safe
    interp share "" stdout xsafe
    list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}

test interp-15.6 {testing file sharing} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.6] w]
    interp share "" $f xsafe
    set x [list [catch [list xsafe eval gets $f] msg] $msg]
    xsafe eval close $f
    close $f
    string compare [string tolower $x] \
		[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
} -cleanup {
    removeFile file-15.6
} -result 0
test interp-15.7 {testing file transferring} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.7] w]
    interp transfer "" $f xsafe
    xsafe eval puts $f hello
    xsafe eval close $f
} -cleanup {
    removeFile file-15.7
} -result ""
test interp-15.8 {testing file transferring} -body {
    catch {interp delete xsafe}
    interp create xsafe -safe
    set f [open [makeFile {} file-15.8] w]
    interp transfer "" $f xsafe
    xsafe eval close $f
    set x [list [catch {close $f} msg] $msg]
    string compare [string tolower $x] \
		[list 1 [format "can not find channel named \"%s\"" $f]]
} -cleanup {
    removeFile file-15.8
} -result 0

#
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}

test interp-15.9 {testing deletion order} {
2429
2430
2431
2432
2433
2434
2435
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
	interp recursionlimit {} 50
	proc p {} {incr ::i; p}
	set i 0
	list [catch p msg] $msg $i
    }]
    interp delete $i
    set r
} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48}

test interp-29.3.2 {recursion limit} {
    set i [interp create]
    interp recursionlimit $i 50
    set r [interp eval $i {
	proc p {} {incr ::i; p}
	set i 0
	list [catch p msg] $msg $i
    }]
   interp delete $i
   set r
} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48}

test interp-29.3.3 {recursion limit} {
    set i [interp create]
    $i recursionlimit 50
    set r [interp eval $i {
	proc p {} {incr ::i; p}
	set i 0
	list [catch p msg] $msg $i
    }]
   interp delete $i
   set r
} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48}

test interp-29.3.4 {recursion limit error reporting} {
    interp create slave
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3







|











|











|







2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
	interp recursionlimit {} 50
	proc p {} {incr ::i; p}
	set i 0
	list [catch p msg] $msg $i
    }]
    interp delete $i
    set r
} {1 {too many nested evaluations (infinite loop?)} 48}

test interp-29.3.2 {recursion limit} {
    set i [interp create]
    interp recursionlimit $i 50
    set r [interp eval $i {
	proc p {} {incr ::i; p}
	set i 0
	list [catch p msg] $msg $i
    }]
   interp delete $i
   set r
} {1 {too many nested evaluations (infinite loop?)} 48}

test interp-29.3.3 {recursion limit} {
    set i [interp create]
    $i recursionlimit 50
    set r [interp eval $i {
	proc p {} {incr ::i; p}
	set i 0
	list [catch p msg] $msg $i
    }]
   interp delete $i
   set r
} {1 {too many nested evaluations (infinite loop?)} 48}

test interp-29.3.4 {recursion limit error reporting} {
    interp create slave
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
	        eval {		# 3
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}

test interp-29.3.8 {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 4}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2







|







2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}

test interp-29.3.8 {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 4}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}

test interp-29.3.9 {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2







|







2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}

test interp-29.3.9 {recursion limit error reporting} {
    interp create slave
    after 0 {interp recursionlimit slave 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}

test interp-29.3.11 {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 5}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2







|







2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}

test interp-29.3.11 {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 5}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}

test interp-29.3.12 {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2







|







2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
		}
	    }
	} msg
    }]
    set r2 [slave eval { set msg }]
    interp delete slave
    list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}

test interp-29.3.12 {recursion limit error reporting} {
    interp create slave
    after 0 {slave recursionlimit 6}
    set r1 [slave eval {
        catch { 		# nesting level 1
	    eval {		# 2
2864
2865
2866
2867
2868
2869
2870

2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882

2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
    rename mySet {}
    rename myNewSet {}
    set result
} ok

test interp-32.1 { parent's working directory should
                   be inherited by a child interp } {

    set parent [pwd]
    set i [interp create]
    set child [$i eval pwd]
    interp delete $i
    file mkdir cwd_test
    cd cwd_test
    lappend parent [pwd]
    set i [interp create]
    lappend child [$i eval pwd]
    cd ..
    file delete cwd_test
    interp delete $i

    expr {[string equal $parent $child] ? 1 :
             "\{$parent\} != \{$child\}"}
} 1

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return







>












>










2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
    rename mySet {}
    rename myNewSet {}
    set result
} ok

test interp-32.1 { parent's working directory should
                   be inherited by a child interp } {
    cd [temporaryDirectory]
    set parent [pwd]
    set i [interp create]
    set child [$i eval pwd]
    interp delete $i
    file mkdir cwd_test
    cd cwd_test
    lappend parent [pwd]
    set i [interp create]
    lappend child [$i eval pwd]
    cd ..
    file delete cwd_test
    interp delete $i
    cd [workingDirectory]
    expr {[string equal $parent $child] ? 1 :
             "\{$parent\} != \{$child\}"}
} 1

# cleanup
foreach i [interp slaves] {
  interp delete $i
}
::tcltest::cleanupTests
return
Changes to tests/io.test.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

32
33
34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51
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
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.21.4.2 2002/06/10 05:33:16 wolfsuit 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]]


# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0

removeFile test1
removeFile pipe

# set up a long data file for some of the following tests


set f [open longfile w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
    puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
    }
close $f

makeFile {
    set f stdin
    if {$argv != ""} {
	set f [open $argv]
    }
    fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a
    fconfigure stdout -encoding binary -translation lf -buffering none
    fileevent $f readable "foo $f"
    proc foo {f} {
	set x [read $f]
	catch {puts -nonewline $x}
	if {[eof $f]} {
	    close $f
	    exit 0
	}
    }
    vwait forever
} cat

set thisScript [file join [pwd] [info script]]

proc contents {file} {
    set f [open $file]
    fconfigure $f -translation binary
    set a [read $f]
    close $f
    return $a
}

test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
    # no test, need to cause an async error.
} {}



test io-1.6 {Tcl_WriteChars: WriteBytes} {
    set f [open test1 w]
    fconfigure $f -encoding binary
    puts -nonewline $f "a\u4e4d\0"
    close $f
    contents test1
} "a\x4d\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
    set f [open test1 w]
    fconfigure $f -encoding shiftjis
    puts -nonewline $f "a\u4e4d\0"
    close $f
    contents test1
} "a\x93\xe1\x00"



test io-1.8 {Tcl_WriteChars: WriteChars} {
    # This test written for SF bug #506297.
    #
    # Executing this test without the fix for the referenced bug
    # applied to tcl will cause tcl, more specifically WriteChars, to
    # go into an infinite loop.

    set f [open test2 w] 
    fconfigure      $f -encoding iso2022-jp 
    puts -nonewline $f [format %s%c [string repeat " " 4] 12399] 
    close           $f 
    contents test2
} "    \x1b\$B\$O\x1b(B"

test io-2.1 {WriteBytes} {
    # loop until all bytes are written
    
    set f [open test1 w]
    fconfigure $f  -encoding binary -buffersize 16 -translation crlf
    puts $f "abcdefghijklmnopqrstuvwxyz"
    close $f
    contents test1
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
    # After flushing buffer, there was a \n left over from the last
    # \n -> \r\n expansion.  It gets stuck at beginning of this buffer.

    set f [open test1 w]
    fconfigure $f -encoding binary -buffersize 16 -translation crlf
    puts -nonewline $f "123456789012345\n12"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-2.3 {WriteBytes: flush on line} {
    # Tcl "line" buffering has weird behavior: if current buffer contains
    # a \n, entire buffer gets flushed.  Logical behavior would be to flush
    # only up to the \n.
    
    set f [open test1 w]
    fconfigure $f -encoding binary -buffering line -translation crlf
    puts -nonewline $f "\n12"
    set x [contents test1]
    close $f
    set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
    set f [open test1 w]
     fconfigure $f -encoding binary -buffering line -translation lf \
	     -buffersize 16
    puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]

test io-3.1 {WriteChars: compatibility with WriteBytes} {
    # loop until all bytes are written
    
    set f [open test1 w]
    fconfigure $f -encoding ascii -buffersize 16 -translation crlf
    puts $f "abcdefghijklmnopqrstuvwxyz"
    close $f
    contents test1
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
    # After flushing buffer, there was a \n left over from the last
    # \n -> \r\n expansion.  It gets stuck at beginning of this buffer.

    set f [open test1 w]
    fconfigure $f -encoding ascii -buffersize 16 -translation crlf
    puts -nonewline $f "123456789012345\n12"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
    # Tcl "line" buffering has weird behavior: if current buffer contains
    # a \n, entire buffer gets flushed.  Logical behavior would be to flush
    # only up to the \n.
    
    set f [open test1 w]
    fconfigure $f -encoding ascii -buffering line -translation crlf
    puts -nonewline $f "\n12"
    set x [contents test1]
    close $f
    set x
} "\r\n12"
test io-3.4 {WriteChars: loop over stage buffer} {
    # stage buffer maps to more than can be queued at once.

    set f [open test1 w]
    fconfigure $f -encoding jis0208 -buffersize 16 
    puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} {
    # Bytes produced by UtfToExternal from end of last channel buffer
    # had to be moved to beginning of next channel buffer to preserve
    # requested buffersize.

    set f [open test1 w]
    fconfigure $f -encoding jis0208 -buffersize 17 
    puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
    # One incomplete UTF-8 character at end of staging buffer.  Backup
    # in src to the beginning of that UTF-8 character and try again.
    #
    # Translate the first 16 bytes, produce 14 bytes of output, 2 left over
    # (first two bytes of \uff21 in UTF-8).  Given those two bytes try
    # translating them again, find that no bytes are read produced, and break
    # to outer loop where those two bytes will have the remaining 4 bytes
    # (the last byte of \uff21 plus the all of \uff22) appended.

    set f [open test1 w]
    fconfigure $f -encoding shiftjis -buffersize 16
    puts -nonewline $f "12345678901234\uff21\uff22"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
    # When translating UTF-8 to external, the produced bytes went past end
    # of the channel buffer.  This is done purpose -- we then truncate the
    # bytes at the end of the partial character to preserve the requested
    # blocksize on flush.  The truncated bytes are moved to the beginning
    # of the next channel buffer.

    set f [open test1 w]
    fconfigure $f -encoding jis0208 -buffersize 17 
    puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
    set f [open test1 w]
    fconfigure $f -encoding ascii -buffering line -translation lf \
	     -buffersize 16
    puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]

test io-4.1 {TranslateOutputEOL: lf} {
    # search for \n

    set f [open test1 w]
    fconfigure $f -buffering line -translation lf
    puts $f "abcde"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "abcde\n" "abcde\n"]
test io-4.2 {TranslateOutputEOL: cr} {
    # search for \n, replace with \r

    set f [open test1 w]
    fconfigure $f -buffering line -translation cr
    puts $f "abcde"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "abcde\r" "abcde\r"]
test io-4.3 {TranslateOutputEOL: crlf} {
    # simple case: search for \n, replace with \r

    set f [open test1 w]
    fconfigure $f -buffering line -translation crlf
    puts $f "abcde"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "abcde\r\n" "abcde\r\n"]
test io-4.4 {TranslateOutputEOL: crlf} {
    # keep storing more bytes in output buffer until output buffer is full.
    # We have 13 bytes initially that would turn into 18 bytes.  Fill
    # dest buffer while (dstEnd < dstMax).

    set f [open test1 w]
    fconfigure $f -translation crlf -buffersize 16
    puts -nonewline $f "1234567\n\n\n\n\nA"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
test io-4.5 {TranslateOutputEOL: crlf} {
    # Check for overflow of the destination buffer

    set f [open test1 w]
    fconfigure $f -translation crlf -buffersize 12
    puts -nonewline $f "12345678901\n456789012345678901234"
    close $f
    set x [contents test1]
} "12345678901\r\n456789012345678901234"

test io-5.1 {CheckFlush: not full} {
    set f [open test1 w]
    fconfigure $f 
    puts -nonewline $f "12345678901234567890"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
    set f [open test1 w]
    fconfigure $f -buffersize 16
    puts -nonewline $f "12345678901234567890"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "1234567890123456" "12345678901234567890"]
test io-5.3 {CheckFlush: not line} {
    set f [open test1 w]
    fconfigure $f -buffering line
    puts -nonewline $f "12345678901234567890"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "" "12345678901234567890"]
test io-5.4 {CheckFlush: line} {
    set f [open test1 w]
    fconfigure $f -buffering line -translation lf -encoding ascii
    puts -nonewline $f "1234567890\n1234567890"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "1234567890\n1234567890" "1234567890\n1234567890"]
test io-5.5 {CheckFlush: none} {
    set f [open test1 w]
    fconfigure $f -buffering none
    puts -nonewline $f "1234567890"
    set x [list [contents test1]]
    close $f
    lappend x [contents test1]
} [list "1234567890" "1234567890"]

test io-6.1 {Tcl_GetsObj: working} {
    set f [open test1 w]
    puts $f "foo\nboo"
    close $f
    set f [open test1]
    set x [gets $f]
    close $f
    set x
} {foo}
test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} {
    # no test, need to cause an async error.
} {}
test io-6.3 {Tcl_GetsObj: how many have we used?} {
    # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}

    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f "abc\ndefg"
    close $f
    set f [open test1]
    set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
    close $f
    set x
} {0 3 5 4 defg}
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
    set f [open test1 w]
    fconfigure $f -translation binary
    puts $f "\x81\u1234\0"
    close $f
    set f [open test1]
    fconfigure $f -translation binary
    set x [list [gets $f line] $line]
    close $f
    set x
} [list 3 "\x81\x34\x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
    set f [open test1 w]
    fconfigure $f -translation binary
    puts $f "\x88\xea\x92\x9a"
    close $f
    set f [open test1]
    fconfigure $f -encoding shiftjis
    set x [list [gets $f line] $line]
    close $f
    set x
} [list 2 "\u4e00\u4e01"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
test io-6.6 {Tcl_GetsObj: loop test} {
    # if (dst >= dstEnd) 

    set f [open test1 w]
    puts $f $a
    puts $f hi
    close $f
    set f [open test1]
    set x [list [gets $f line] $line]
    close $f
    set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} {stdio} {
    # if (FilterInputBytes(chanPtr, &gs) != 0)

    set f [open "|[list [interpreter] cat]" w+]
    puts -nonewline $f "hi\nwould"
    flush $f
    gets $f
    fconfigure $f -blocking 0
    set x [gets $f line]
    close $f
    set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
    set f [open test1 w]
    puts $f "abcdef\x1aghijk\nwombat"
    close $f
    set f [open test1]
    fconfigure $f -eofchar \x1a
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
    set f [open test1 w]
    puts $f "abcdefghijk\nwom\u001abat"
    close $f
    set f [open test1]
    fconfigure $f -eofchar \x1a
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {11 abcdefghijk 3 wom}

# Comprehensive tests

test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
    set f [open test1 w]
    close $f
    set f [open test1]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open test1]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {0 {} -1 {}}
test io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open test1]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\r" -1 ""]
test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open test1]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\n"
    close $f
    set f [open test1]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open test1]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
    set f [open test1 w]
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\n" -1 ""]
test io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {0 {} -1 {}}
test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\r"
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
    set f [open test1 w]
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\n" -1 ""]
test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\r" -1 ""]
test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\r"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 2 "\r\r" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\n"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\r\n"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
    # if (eol >= dstEnd)

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [testchannel inputbuffered $f]]
    close $f
    set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel} {
    # (FilterInputBytes() != 0)

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {crlf lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
    fconfigure $f -buffersize 16
    set x [gets $f]
    fconfigure $f -blocking 0
    lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f]
    close $f
    set x
} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
    # not (FilterInputBytes() != 0)

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r\n123"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
    close $f
    set x
} [list 15 "123456789012345" 17 3]
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
    # eol still equals dstEnd
    
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} [list 16 "123456789012345\r" 1]
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
    # not (*eol == '\n') 
    
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\rabcd\r\nefg"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [tell $f]]
    close $f
    set x
} [list 20 "123456789012345\rabcd" 22]
test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
    set f [open test1 w]
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\r"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" 0 "" -1 ""]
test io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\n"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\r\n"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
    close $f
    set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel} {
    # if (chanPtr->flags & INPUT_SAW_CR)

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    set x [list [gets $f]]
    fconfigure $f -blocking 0
    lappend x [gets $f line] $line [testchannel queuedcr $f] 
    fconfigure $f -blocking 1
    puts -nonewline $f "\nabcd\refg\x1a"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    lappend x [gets $f line] $line
    close $f
    set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel} {
    # not (*eol == '\n') 

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    set x [list [gets $f]]
    fconfigure $f -blocking 0
    lappend x [gets $f line] $line [testchannel queuedcr $f] 
    fconfigure $f -blocking 1
    puts -nonewline $f "abcd\refg\x1a"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    lappend x [gets $f line] $line
    close $f
    set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel} {
    # Tcl_ExternalToUtf()

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    fconfigure $f -encoding unicode
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    gets $f
    fconfigure $f -blocking 0
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    fconfigure $f -blocking 1
    puts -nonewline $f "\nabcd\refg"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    close $f
    set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel} {
    # memmove()

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    gets $f
    fconfigure $f -blocking 0
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    fconfigure $f -blocking 1
    puts -nonewline $f "\n\x1a"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    close $f
    set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
    # (eol == dstEnd)

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq"
    close $f
    set f [open test1]
    fconfigure $f -translation auto -buffersize 16
    set x [list [gets $f] [testchannel inputbuffered $f]]
    close $f
    set x
} [list "123456789012345" 15]    
test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
    # PeekAhead() did not get any, so (eol >= dstEnd)
    
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r"
    close $f
    set f [open test1]
    fconfigure $f -translation auto -buffersize 16
    set x [list [gets $f] [testchannel queuedcr $f]]
    close $f
    set x
} [list "123456789012345" 1]
test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
    # if (*eol == '\n') {skip++}
    
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\r\n78901"
    close $f
    set f [open test1]
    set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 0 8 "78901"]
test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
    # not (*eol == '\n') 
    
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\r78901"
    close $f
    set f [open test1]
    set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 0 7 "78901"]
test io-6.51 {Tcl_GetsObj: auto mode: \n} {
    # else if (*eol == '\n') {goto gotoeol;}
    
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\n78901"
    close $f
    set f [open test1]
    set x [list [gets $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
    # if (eof != NULL)

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\x1ak9012345\r"
    close $f
    set f [open test1]
    fconfigure $f -eofchar \x1a
    set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 0 6 ""]
test io-6.53 {Tcl_GetsObj: device EOF} {
    # didn't produce any bytes

    set f [open test1 w]
    close $f
    set f [open test1]
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} {-1 {} 1}
test io-6.54 {Tcl_GetsObj: device EOF} {
    # got some bytes before EOF.

    set f [open test1 w]
    puts -nonewline $f abc
    close $f
    set f [open test1]
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} {3 abc 1}
test io-6.55 {Tcl_GetsObj: overconverted} {
    # Tcl_ExternalToUtf(), make sure state updated

    set f [open test1 w]
    fconfigure $f -encoding iso2022-jp
    puts $f "there\u4e00ok\n\u4e01more bytes\nhere"
    close $f
    set f [open test1]
    fconfigure $f -encoding iso2022-jp
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio} {
    update
    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -buffering none
    puts -nonewline $f "foobar"
    fconfigure $f -blocking 0
    variable x {}
    after 500 [namespace code { lappend x timeout }]
    fileevent $f readable [namespace code { lappend x [gets $f] }]
    vwait [namespace which -variable x]







|
















>










>
|








|
















|














>
>
>

|



|


|



|

>
>
>







|



|





|



|





|


|

|






|


|




|



|

|





|



|





|


|

|






|


|






|


|

|






|


|

|











|


|

|








|


|

|


|



|

|





|


|

|




|


|

|




|


|

|






|


|

|




|



|



|


|

|


|


|

|


|


|

|


|


|

|


|


|

|



|


|










|



|





|



|






|



|











|



|

















|


|






|


|









|

|






|



|






|



|






|



|






|



|






|



|






|

|






|



|






|



|






|



|






|



|






|



|






|

|






|



|






|



|






|



|






|



|






|



|






|



|






|



|








|



|








|












|



|








|



|








|



|






|

|






|



|






|



|






|



|






|



|






|



|






|



|






|



|









|
















|
















|
















|















|



|








|



|








|



|







|



|







|



|







|



|








|

|







|


|







|



|







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.21.4.3 2002/08/20 20:25:28 das Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::io {

    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::interpreter
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::viewFile

testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0

removeFile test1
removeFile pipe

# set up a long data file for some of the following tests

set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
    puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
\#123456789abcdef01
\#"
    }
close $f

set path(cat) [makeFile {
    set f stdin
    if {$argv != ""} {
	set f [open $argv]
    }
    fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a
    fconfigure stdout -encoding binary -translation lf -buffering none
    fileevent $f readable "foo $f"
    proc foo {f} {
	set x [read $f]
	catch {puts -nonewline $x}
	if {[eof $f]} {
	    close $f
	    exit 0
	}
    }
    vwait forever
} cat]

set thisScript [file join [pwd] [info script]]

proc contents {file} {
    set f [open $file]
    fconfigure $f -translation binary
    set a [read $f]
    close $f
    return $a
}

test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
    # no test, need to cause an async error.
} {}

set path(test1) [makeFile {} test1]

test io-1.6 {Tcl_WriteChars: WriteBytes} {
    set f [open $path(test1) w]
    fconfigure $f -encoding binary
    puts -nonewline $f "a\u4e4d\0"
    close $f
    contents $path(test1)
} "a\x4d\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
    set f [open $path(test1) w]
    fconfigure $f -encoding shiftjis
    puts -nonewline $f "a\u4e4d\0"
    close $f
    contents $path(test1)
} "a\x93\xe1\x00"

set path(test2) [makeFile {} test2]

test io-1.8 {Tcl_WriteChars: WriteChars} {
    # This test written for SF bug #506297.
    #
    # Executing this test without the fix for the referenced bug
    # applied to tcl will cause tcl, more specifically WriteChars, to
    # go into an infinite loop.

    set f [open $path(test2) w] 
    fconfigure      $f -encoding iso2022-jp 
    puts -nonewline $f [format %s%c [string repeat " " 4] 12399] 
    close           $f 
    contents $path(test2)
} "    \x1b\$B\$O\x1b(B"

test io-2.1 {WriteBytes} {
    # loop until all bytes are written
    
    set f [open $path(test1) w]
    fconfigure $f  -encoding binary -buffersize 16 -translation crlf
    puts $f "abcdefghijklmnopqrstuvwxyz"
    close $f
    contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
    # After flushing buffer, there was a \n left over from the last
    # \n -> \r\n expansion.  It gets stuck at beginning of this buffer.

    set f [open $path(test1) w]
    fconfigure $f -encoding binary -buffersize 16 -translation crlf
    puts -nonewline $f "123456789012345\n12"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-2.3 {WriteBytes: flush on line} {
    # Tcl "line" buffering has weird behavior: if current buffer contains
    # a \n, entire buffer gets flushed.  Logical behavior would be to flush
    # only up to the \n.
    
    set f [open $path(test1) w]
    fconfigure $f -encoding binary -buffering line -translation crlf
    puts -nonewline $f "\n12"
    set x [contents $path(test1)]
    close $f
    set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
    set f [open $path(test1) w]
     fconfigure $f -encoding binary -buffering line -translation lf \
	     -buffersize 16
    puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]

test io-3.1 {WriteChars: compatibility with WriteBytes} {
    # loop until all bytes are written
    
    set f [open $path(test1) w]
    fconfigure $f -encoding ascii -buffersize 16 -translation crlf
    puts $f "abcdefghijklmnopqrstuvwxyz"
    close $f
    contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
    # After flushing buffer, there was a \n left over from the last
    # \n -> \r\n expansion.  It gets stuck at beginning of this buffer.

    set f [open $path(test1) w]
    fconfigure $f -encoding ascii -buffersize 16 -translation crlf
    puts -nonewline $f "123456789012345\n12"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
    # Tcl "line" buffering has weird behavior: if current buffer contains
    # a \n, entire buffer gets flushed.  Logical behavior would be to flush
    # only up to the \n.
    
    set f [open $path(test1) w]
    fconfigure $f -encoding ascii -buffering line -translation crlf
    puts -nonewline $f "\n12"
    set x [contents $path(test1)]
    close $f
    set x
} "\r\n12"
test io-3.4 {WriteChars: loop over stage buffer} {
    # stage buffer maps to more than can be queued at once.

    set f [open $path(test1) w]
    fconfigure $f -encoding jis0208 -buffersize 16 
    puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} {
    # Bytes produced by UtfToExternal from end of last channel buffer
    # had to be moved to beginning of next channel buffer to preserve
    # requested buffersize.

    set f [open $path(test1) w]
    fconfigure $f -encoding jis0208 -buffersize 17 
    puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
    # One incomplete UTF-8 character at end of staging buffer.  Backup
    # in src to the beginning of that UTF-8 character and try again.
    #
    # Translate the first 16 bytes, produce 14 bytes of output, 2 left over
    # (first two bytes of \uff21 in UTF-8).  Given those two bytes try
    # translating them again, find that no bytes are read produced, and break
    # to outer loop where those two bytes will have the remaining 4 bytes
    # (the last byte of \uff21 plus the all of \uff22) appended.

    set f [open $path(test1) w]
    fconfigure $f -encoding shiftjis -buffersize 16
    puts -nonewline $f "12345678901234\uff21\uff22"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
    # When translating UTF-8 to external, the produced bytes went past end
    # of the channel buffer.  This is done purpose -- we then truncate the
    # bytes at the end of the partial character to preserve the requested
    # blocksize on flush.  The truncated bytes are moved to the beginning
    # of the next channel buffer.

    set f [open $path(test1) w]
    fconfigure $f -encoding jis0208 -buffersize 17 
    puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
    set f [open $path(test1) w]
    fconfigure $f -encoding ascii -buffering line -translation lf \
	     -buffersize 16
    puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]

test io-4.1 {TranslateOutputEOL: lf} {
    # search for \n

    set f [open $path(test1) w]
    fconfigure $f -buffering line -translation lf
    puts $f "abcde"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "abcde\n" "abcde\n"]
test io-4.2 {TranslateOutputEOL: cr} {
    # search for \n, replace with \r

    set f [open $path(test1) w]
    fconfigure $f -buffering line -translation cr
    puts $f "abcde"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "abcde\r" "abcde\r"]
test io-4.3 {TranslateOutputEOL: crlf} {
    # simple case: search for \n, replace with \r

    set f [open $path(test1) w]
    fconfigure $f -buffering line -translation crlf
    puts $f "abcde"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "abcde\r\n" "abcde\r\n"]
test io-4.4 {TranslateOutputEOL: crlf} {
    # keep storing more bytes in output buffer until output buffer is full.
    # We have 13 bytes initially that would turn into 18 bytes.  Fill
    # dest buffer while (dstEnd < dstMax).

    set f [open $path(test1) w]
    fconfigure $f -translation crlf -buffersize 16
    puts -nonewline $f "1234567\n\n\n\n\nA"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
test io-4.5 {TranslateOutputEOL: crlf} {
    # Check for overflow of the destination buffer

    set f [open $path(test1) w]
    fconfigure $f -translation crlf -buffersize 12
    puts -nonewline $f "12345678901\n456789012345678901234"
    close $f
    set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"

test io-5.1 {CheckFlush: not full} {
    set f [open $path(test1) w]
    fconfigure $f 
    puts -nonewline $f "12345678901234567890"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
    set f [open $path(test1) w]
    fconfigure $f -buffersize 16
    puts -nonewline $f "12345678901234567890"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "1234567890123456" "12345678901234567890"]
test io-5.3 {CheckFlush: not line} {
    set f [open $path(test1) w]
    fconfigure $f -buffering line
    puts -nonewline $f "12345678901234567890"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.4 {CheckFlush: line} {
    set f [open $path(test1) w]
    fconfigure $f -buffering line -translation lf -encoding ascii
    puts -nonewline $f "1234567890\n1234567890"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "1234567890\n1234567890" "1234567890\n1234567890"]
test io-5.5 {CheckFlush: none} {
    set f [open $path(test1) w]
    fconfigure $f -buffering none
    puts -nonewline $f "1234567890"
    set x [list [contents $path(test1)]]
    close $f
    lappend x [contents $path(test1)]
} [list "1234567890" "1234567890"]

test io-6.1 {Tcl_GetsObj: working} {
    set f [open $path(test1) w]
    puts $f "foo\nboo"
    close $f
    set f [open $path(test1)]
    set x [gets $f]
    close $f
    set x
} {foo}
test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} {
    # no test, need to cause an async error.
} {}
test io-6.3 {Tcl_GetsObj: how many have we used?} {
    # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}

    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f "abc\ndefg"
    close $f
    set f [open $path(test1)]
    set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
    close $f
    set x
} {0 3 5 4 defg}
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
    set f [open $path(test1) w]
    fconfigure $f -translation binary
    puts $f "\x81\u1234\0"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation binary
    set x [list [gets $f line] $line]
    close $f
    set x
} [list 3 "\x81\x34\x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
    set f [open $path(test1) w]
    fconfigure $f -translation binary
    puts $f "\x88\xea\x92\x9a"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding shiftjis
    set x [list [gets $f line] $line]
    close $f
    set x
} [list 2 "\u4e00\u4e01"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
test io-6.6 {Tcl_GetsObj: loop test} {
    # if (dst >= dstEnd) 

    set f [open $path(test1) w]
    puts $f $a
    puts $f hi
    close $f
    set f [open $path(test1)]
    set x [list [gets $f line] $line]
    close $f
    set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} {stdio} {
    # if (FilterInputBytes(chanPtr, &gs) != 0)

    set f [open "|[list [interpreter] cat]" w+]
    puts -nonewline $f "hi\nwould"
    flush $f
    gets $f
    fconfigure $f -blocking 0
    set x [gets $f line]
    close $f
    set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
    set f [open $path(test1) w]
    puts $f "abcdef\x1aghijk\nwombat"
    close $f
    set f [open $path(test1)]
    fconfigure $f -eofchar \x1a
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
    set f [open $path(test1) w]
    puts $f "abcdefghijk\nwom\u001abat"
    close $f
    set f [open $path(test1)]
    fconfigure $f -eofchar \x1a
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {11 abcdefghijk 3 wom}

# Comprehensive tests

test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {0 {} -1 {}}
test io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\r" -1 ""]
test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation lf
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\n" -1 ""]
test io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {0 {} -1 {}}
test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\n" -1 ""]
test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 1 "\r" -1 ""]
test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 2 "\r\r" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\r\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
    # if (eol >= dstEnd)

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [testchannel inputbuffered $f]]
    close $f
    set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel} {
    # (FilterInputBytes() != 0)

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {crlf lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
    fconfigure $f -buffersize 16
    set x [gets $f]
    fconfigure $f -blocking 0
    lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f]
    close $f
    set x
} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
    # not (FilterInputBytes() != 0)

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r\n123"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
    close $f
    set x
} [list 15 "123456789012345" 17 3]
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
    # eol still equals dstEnd
    
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} [list 16 "123456789012345\r" 1]
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
    # not (*eol == '\n') 
    
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\rabcd\r\nefg"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf -buffersize 16
    set x [list [gets $f line] $line [tell $f]]
    close $f
    set x
} [list 20 "123456789012345\rabcd" 22]
test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line]
    close $f
    set x
} {-1 {}}
test io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" 0 "" -1 ""]
test io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 0 "" -1 ""]
test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f a
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\r\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} {1 a -1 {}}
test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [gets $f line] $line [gets $f line] $line]
    lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
    close $f
    set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel} {
    # if (chanPtr->flags & INPUT_SAW_CR)

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    set x [list [gets $f]]
    fconfigure $f -blocking 0
    lappend x [gets $f line] $line [testchannel queuedcr $f] 
    fconfigure $f -blocking 1
    puts -nonewline $f "\nabcd\refg\x1a"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    lappend x [gets $f line] $line
    close $f
    set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel} {
    # not (*eol == '\n') 

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    set x [list [gets $f]]
    fconfigure $f -blocking 0
    lappend x [gets $f line] $line [testchannel queuedcr $f] 
    fconfigure $f -blocking 1
    puts -nonewline $f "abcd\refg\x1a"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    lappend x [gets $f line] $line
    close $f
    set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel} {
    # Tcl_ExternalToUtf()

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    fconfigure $f -encoding unicode
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    gets $f
    fconfigure $f -blocking 0
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    fconfigure $f -blocking 1
    puts -nonewline $f "\nabcd\refg"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    close $f
    set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel} {
    # memmove()

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto lf} -buffering none
    puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
    fconfigure $f -buffersize 16
    gets $f
    fconfigure $f -blocking 0
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    fconfigure $f -blocking 1
    puts -nonewline $f "\n\x1a"
    lappend x [gets $f line] $line [testchannel queuedcr $f]
    close $f
    set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
    # (eol == dstEnd)

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto -buffersize 16
    set x [list [gets $f] [testchannel inputbuffered $f]]
    close $f
    set x
} [list "123456789012345" 15]    
test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
    # PeekAhead() did not get any, so (eol >= dstEnd)
    
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456789012345\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto -buffersize 16
    set x [list [gets $f] [testchannel queuedcr $f]]
    close $f
    set x
} [list "123456789012345" 1]
test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
    # if (*eol == '\n') {skip++}
    
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\r\n78901"
    close $f
    set f [open $path(test1)]
    set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 0 8 "78901"]
test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
    # not (*eol == '\n') 
    
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\r78901"
    close $f
    set f [open $path(test1)]
    set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 0 7 "78901"]
test io-6.51 {Tcl_GetsObj: auto mode: \n} {
    # else if (*eol == '\n') {goto gotoeol;}
    
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\n78901"
    close $f
    set f [open $path(test1)]
    set x [list [gets $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
    # if (eof != NULL)

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "123456\x1ak9012345\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -eofchar \x1a
    set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
    close $f
    set x
} [list "123456" 0 6 ""]
test io-6.53 {Tcl_GetsObj: device EOF} {
    # didn't produce any bytes

    set f [open $path(test1) w]
    close $f
    set f [open $path(test1)]
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} {-1 {} 1}
test io-6.54 {Tcl_GetsObj: device EOF} {
    # got some bytes before EOF.

    set f [open $path(test1) w]
    puts -nonewline $f abc
    close $f
    set f [open $path(test1)]
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} {3 abc 1}
test io-6.55 {Tcl_GetsObj: overconverted} {
    # Tcl_ExternalToUtf(), make sure state updated

    set f [open $path(test1) w]
    fconfigure $f -encoding iso2022-jp
    puts $f "there\u4e00ok\n\u4e01more bytes\nhere"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding iso2022-jp
    set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
    close $f
    set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio} {
    update
    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -buffering none
    puts -nonewline $f "foobar"
    fconfigure $f -blocking 0
    variable x {}
    after 500 [namespace code { lappend x timeout }]
    fileevent $f readable [namespace code { lappend x [gets $f] }]
    vwait [namespace which -variable x]
996
997
998
999
1000
1001
1002
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
    close $f
    set x
} {{} timeout foobarbaz timeout}

test io-7.1 {FilterInputBytes: split up character at end of buffer} {
    # (result == TCL_CONVERT_MULTIBYTE)

    set f [open test1 w]
    fconfigure $f -encoding shiftjis
    puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend"
    close $f
    set f [open test1]
    fconfigure $f -encoding shiftjis -buffersize 16
    set x [gets $f]
    close $f
    set x
} "1234567890123\uff10\uff11\uff12\uff13\uff14"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
    # (bufPtr->nextAdded < bufPtr->bufLength)
    
    set f [open test1 w]
    fconfigure $f -encoding binary
    puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
    close $f
    set f [open test1]
    fconfigure $f -encoding shiftjis
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
    set f [open test1 w]
    fconfigure $f -encoding binary
    puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
    close $f
    set f [open test1]
    fconfigure $f -encoding shiftjis
    set x [list [gets $f line] $line]
    lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
    lappend x [gets $f line] $line
    close $f
    set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio} {
    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -encoding binary -buffering none
    puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
    fconfigure $f -encoding shiftjis -blocking 0
    fileevent $f read [namespace code "ready $f"]
    variable x {}
    proc ready {f} {
	variable x







|



|








|



|






|



|








|







1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
    close $f
    set x
} {{} timeout foobarbaz timeout}

test io-7.1 {FilterInputBytes: split up character at end of buffer} {
    # (result == TCL_CONVERT_MULTIBYTE)

    set f [open $path(test1) w]
    fconfigure $f -encoding shiftjis
    puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding shiftjis -buffersize 16
    set x [gets $f]
    close $f
    set x
} "1234567890123\uff10\uff11\uff12\uff13\uff14"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
    # (bufPtr->nextAdded < bufPtr->bufLength)
    
    set f [open $path(test1) w]
    fconfigure $f -encoding binary
    puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding shiftjis
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
    set f [open $path(test1) w]
    fconfigure $f -encoding binary
    puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding shiftjis
    set x [list [gets $f line] $line]
    lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
    lappend x [gets $f line] $line
    close $f
    set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio} {
    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -encoding binary -buffering none
    puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
    fconfigure $f -encoding shiftjis -blocking 0
    fileevent $f read [namespace code "ready $f"]
    variable x {}
    proc ready {f} {
	variable x
1055
1056
1057
1058
1059
1060
1061
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
    close $f
    set x
} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]

test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
    # (bufPtr->nextPtr == NULL)

    set f [open "test1" w]
    fconfigure $f -encoding ascii -translation lf
    puts -nonewline $f "123456789012345\r\n2345678"
    close $f
    set f [open "test1"]
    fconfigure $f -encoding ascii -translation auto -buffersize 16
    # here
    gets $f
    set x [testchannel inputbuffered $f]
    close $f
    set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel} {
    # not (bufPtr->nextPtr == NULL)

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation lf -encoding ascii -buffering none
    puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
    variable x {}
    fileevent $f read [namespace code "ready $f"]
    proc ready {f} {
	variable x
	lappend x [gets $f line] $line [testchannel inputbuffered $f]
    }
    fconfigure $f -encoding unicode -buffersize 16 -blocking 0
    vwait [namespace which -variable x]
    fconfigure $f -translation auto -encoding ascii -blocking 1
    # here
    vwait [namespace which -variable x]
    close $f
    set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel} {
    # (bytesLeft == 0)

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto binary}
    puts -nonewline $f "abcdefghijklmno\r"
    flush $f
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    close $f
    set x
} [list 15 "abcdefghijklmno" 1]
set a "123456789012345678901234567890"
append a "123456789012345678901234567890"
append a "1234567890123456789012345678901"
test io-8.4 {PeekAhead: cached data available in this buffer} {
    # not (bytesLeft == 0)

    set f [open test1 w+]
    fconfigure $f -translation binary
    puts $f "${a}\r\nabcdef"
    close $f
    set f [open test1]
    fconfigure $f -encoding binary -translation auto

    # "${a}\r" was converted in one operation (because ENCODING_LINESIZE
    # is 30).  To check if "\n" follows, calls PeekAhead and determines
    # that cached data is available in buffer w/o having to call driver.

    set x [gets $f]
    close $f
    set x    
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel} {
    # (bufPtr->nextAdded < bufPtr->length)

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto binary}
    puts -nonewline $f "abcdefghijklmno\r"
    flush $f
    # here
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    close $f
    set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel} {
    # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) 

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto binary} -buffersize 16
    puts -nonewline $f "abcdefghijklmno\r"
    flush $f
    # here
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    close $f
    set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel} {
    # Make sure bytes are removed from buffer.

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -translation {auto binary} -buffering none
    puts -nonewline $f "abcdefghijklmno\r"
    # here
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    puts -nonewline $f "\x1a"
    lappend x [gets $f line] $line
    close $f







|



|










|



















|













|



|














|











|











|







1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
    close $f
    set x
} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]

test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
    # (bufPtr->nextPtr == NULL)

    set f [open $path(test1) w]
    fconfigure $f -encoding ascii -translation lf
    puts -nonewline $f "123456789012345\r\n2345678"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding ascii -translation auto -buffersize 16
    # here
    gets $f
    set x [testchannel inputbuffered $f]
    close $f
    set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel} {
    # not (bufPtr->nextPtr == NULL)

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation lf -encoding ascii -buffering none
    puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
    variable x {}
    fileevent $f read [namespace code "ready $f"]
    proc ready {f} {
	variable x
	lappend x [gets $f line] $line [testchannel inputbuffered $f]
    }
    fconfigure $f -encoding unicode -buffersize 16 -blocking 0
    vwait [namespace which -variable x]
    fconfigure $f -translation auto -encoding ascii -blocking 1
    # here
    vwait [namespace which -variable x]
    close $f
    set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel} {
    # (bytesLeft == 0)

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto binary}
    puts -nonewline $f "abcdefghijklmno\r"
    flush $f
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    close $f
    set x
} [list 15 "abcdefghijklmno" 1]
set a "123456789012345678901234567890"
append a "123456789012345678901234567890"
append a "1234567890123456789012345678901"
test io-8.4 {PeekAhead: cached data available in this buffer} {
    # not (bytesLeft == 0)

    set f [open $path(test1) w+]
    fconfigure $f -translation binary
    puts $f "${a}\r\nabcdef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding binary -translation auto

    # "${a}\r" was converted in one operation (because ENCODING_LINESIZE
    # is 30).  To check if "\n" follows, calls PeekAhead and determines
    # that cached data is available in buffer w/o having to call driver.

    set x [gets $f]
    close $f
    set x    
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel} {
    # (bufPtr->nextAdded < bufPtr->length)

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto binary}
    puts -nonewline $f "abcdefghijklmno\r"
    flush $f
    # here
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    close $f
    set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel} {
    # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) 

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto binary} -buffersize 16
    puts -nonewline $f "abcdefghijklmno\r"
    flush $f
    # here
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    close $f
    set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel} {
    # Make sure bytes are removed from buffer.

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -translation {auto binary} -buffering none
    puts -nonewline $f "abcdefghijklmno\r"
    # here
    set x [list [gets $f line] $line [testchannel queuedcr $f]]
    puts -nonewline $f "\x1a"
    lappend x [gets $f line] $line
    close $f
1169
1170
1171
1172
1173
1174
1175
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
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
    # no test, need to cause an async error.
} {}
test io-10.2 {Tcl_ReadChars: loop until enough copied} {
    # one time
    # for (copied = 0; (unsigned) toRead > 0; )

    set f [open "test1" w]
    puts $f abcdefghijklmnop
    close $f

    set f [open "test1"]
    set x [read $f 5]
    close $f
    set x
} {abcde}
test io-10.3 {Tcl_ReadChars: loop until enough copied} {
    # multiple times
    # for (copied = 0; (unsigned) toRead > 0; )

    set f [open "test1" w]
    puts $f abcdefghijklmnopqrstuvwxyz
    close $f

    set f [open "test1"]
    fconfigure $f -buffersize 16
    # here
    set x [read $f 19]
    close $f
    set x
} {abcdefghijklmnopqrs}
test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
    # (copiedNow < 0)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijkl
    close $f

    set f [open "test1"]
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}
test io-10.5 {Tcl_ReadChars: stop on EOF} {
    # (chanPtr->flags & CHANNEL_EOF)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijkl
    close $f

    set f [open "test1"]
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}

test io-11.1 {ReadBytes: want to read a lot} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open "test1"]
    fconfigure $f -encoding binary
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}
test io-11.2 {ReadBytes: want to read all} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open "test1"]
    fconfigure $f -encoding binary
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijkl}
test io-11.3 {ReadBytes: allocate more space} {
    # (toRead > length - offset - 1)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijklmnopqrstuvwxyz
    close $f
    set f [open "test1"]
    fconfigure $f -buffersize 16 -encoding binary
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijklmnopqrstuvwxyz}
test io-11.4 {ReadBytes: EOF char found} {
    # (TranslateInputEOL() != 0)

    set f [open "test1" w]
    puts $f abcdefghijklmnopqrstuvwxyz
    close $f
    set f [open "test1"]
    fconfigure $f -eofchar m -encoding binary
    # here
    set x [list [read $f] [eof $f] [read $f] [eof $f]]
    close $f
    set x
} [list "abcdefghijkl" 1 "" 1]
    
test io-12.1 {ReadChars: want to read a lot} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open "test1"]
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}
test io-12.2 {ReadChars: want to read all} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open "test1"]
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijkl}
test io-12.3 {ReadChars: allocate more space} {
    # (toRead > length - offset - 1)

    set f [open "test1" w]
    puts -nonewline $f abcdefghijklmnopqrstuvwxyz
    close $f
    set f [open "test1"]
    fconfigure $f -buffersize 16
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel} {
    # (srcRead == 0)

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -encoding binary -buffering none -buffersize 16
    puts -nonewline $f "123456789012345\x96"
    fconfigure $f -encoding shiftjis -blocking 0

    fileevent $f read [namespace code "ready $f"]
    proc ready {f} {
	variable x







|



|








|



|









|



|








|



|









|


|









|


|









|


|









|


|










|


|








|


|








|


|









|







1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
    # no test, need to cause an async error.
} {}
test io-10.2 {Tcl_ReadChars: loop until enough copied} {
    # one time
    # for (copied = 0; (unsigned) toRead > 0; )

    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f

    set f [open $path(test1)]
    set x [read $f 5]
    close $f
    set x
} {abcde}
test io-10.3 {Tcl_ReadChars: loop until enough copied} {
    # multiple times
    # for (copied = 0; (unsigned) toRead > 0; )

    set f [open $path(test1) w]
    puts $f abcdefghijklmnopqrstuvwxyz
    close $f

    set f [open $path(test1)]
    fconfigure $f -buffersize 16
    # here
    set x [read $f 19]
    close $f
    set x
} {abcdefghijklmnopqrs}
test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
    # (copiedNow < 0)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijkl
    close $f

    set f [open $path(test1)]
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}
test io-10.5 {Tcl_ReadChars: stop on EOF} {
    # (chanPtr->flags & CHANNEL_EOF)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijkl
    close $f

    set f [open $path(test1)]
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}

test io-11.1 {ReadBytes: want to read a lot} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding binary
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}
test io-11.2 {ReadBytes: want to read all} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding binary
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijkl}
test io-11.3 {ReadBytes: allocate more space} {
    # (toRead > length - offset - 1)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijklmnopqrstuvwxyz
    close $f
    set f [open $path(test1)]
    fconfigure $f -buffersize 16 -encoding binary
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijklmnopqrstuvwxyz}
test io-11.4 {ReadBytes: EOF char found} {
    # (TranslateInputEOL() != 0)

    set f [open $path(test1) w]
    puts $f abcdefghijklmnopqrstuvwxyz
    close $f
    set f [open $path(test1)]
    fconfigure $f -eofchar m -encoding binary
    # here
    set x [list [read $f] [eof $f] [read $f] [eof $f]]
    close $f
    set x
} [list "abcdefghijkl" 1 "" 1]
    
test io-12.1 {ReadChars: want to read a lot} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open $path(test1)]
    # here
    set x [read $f 1000]
    close $f
    set x
} {abcdefghijkl}
test io-12.2 {ReadChars: want to read all} {
    # ((unsigned) toRead > (unsigned) srcLen)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijkl
    close $f
    set f [open $path(test1)]
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijkl}
test io-12.3 {ReadChars: allocate more space} {
    # (toRead > length - offset - 1)

    set f [open $path(test1) w]
    puts -nonewline $f abcdefghijklmnopqrstuvwxyz
    close $f
    set f [open $path(test1)]
    fconfigure $f -buffersize 16
    # here
    set x [read $f]
    close $f
    set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel} {
    # (srcRead == 0)

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -encoding binary -buffering none -buffersize 16
    puts -nonewline $f "123456789012345\x96"
    fconfigure $f -encoding shiftjis -blocking 0

    fileevent $f read [namespace code "ready $f"]
    proc ready {f} {
	variable x
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
    after 500			;# Give the cat process time to catch up
    fconfigure $f -encoding shiftjis -blocking 0
    vwait [namespace which -variable x]
    close $f
    set x
} [list "123456789012345" 1 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio} {
    makeFile {
	fconfigure stdout -encoding binary -buffering none
	gets stdin; puts -nonewline "\xe7"
	gets stdin; puts -nonewline "\x89"
	gets stdin; puts -nonewline "\xa6"
    } test1
    set f [open "|[list [interpreter] test1]" r+]
    fileevent $f readable [namespace code {
	lappend x [read $f]
	if {[eof $f]} {
	    lappend x eof
	}
    }]
    puts $f "go1"







|




|
|







1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
    after 500			;# Give the cat process time to catch up
    fconfigure $f -encoding shiftjis -blocking 0
    vwait [namespace which -variable x]
    close $f
    set x
} [list "123456789012345" 1 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio} {
    set path(test1) [makeFile {
	fconfigure stdout -encoding binary -buffering none
	gets stdin; puts -nonewline "\xe7"
	gets stdin; puts -nonewline "\x89"
	gets stdin; puts -nonewline "\xa6"
    } test1]
    set f [open "|[list [interpreter] $path(test1)]" r+]
    fileevent $f readable [namespace code {
	lappend x [read $f]
	if {[eof $f]} {
	    lappend x eof
	}
    }]
    puts $f "go1"
1370
1371
1372
1373
1374
1375
1376
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
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    lappend x [catch {close $f} msg] $msg
    set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"

test io-13.1 {TranslateInputEOL: cr mode} {} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef\r"
    close $f
    set f [open test1]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "abcd\ndef\n"
test io-13.2 {TranslateInputEOL: crlf mode} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\r\n"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\n"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
    # (src >= srcMax) 

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\r"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\r"
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
    # (src >= srcMax) 

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\rfgh"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\rfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
    # (src >= srcMax) 

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\nfgh"
    close $f
    set f [open test1]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel} {
    # (chanPtr->flags & INPUT_SAW_CR)
    # This test may fail on slower machines.

    set f [open "|[list [interpreter] cat]" w+]
    fconfigure $f -blocking 0 -buffering none -translation {auto lf}

    fileevent $f read [namespace code "ready $f"]
    proc ready {f} {
	variable x
	lappend x [read $f] [testchannel queuedcr $f]
    }







|



|






|



|








|



|








|



|








|



|









|







1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    lappend x [catch {close $f} msg] $msg
    set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"

test io-13.1 {TranslateInputEOL: cr mode} {} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "abcd\ndef\n"
test io-13.2 {TranslateInputEOL: crlf mode} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\r\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\n"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
    # (src >= srcMax) 

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\r"
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
    # (src >= srcMax) 

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\rfgh"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\rfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
    # (src >= srcMax) 

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef\nfgh"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel} {
    # (chanPtr->flags & INPUT_SAW_CR)
    # This test may fail on slower machines.

    set f [open "|[list [interpreter] $path(cat)]" w+]
    fconfigure $f -blocking 0 -buffering none -translation {auto lf}

    fileevent $f read [namespace code "ready $f"]
    proc ready {f} {
	variable x
	lappend x [read $f] [testchannel queuedcr $f]
    }
1459
1460
1461
1462
1463
1464
1465
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

    close $f
    set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} {
    # (src >= srcMax)

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [list [read $f] [testchannel queuedcr $f]]
    close $f
    set x
} [list "abcd\n" 1]
test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
    # (*src == '\n')

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.10 {TranslateInputEOL: auto mode: \n} {
    # not (*src == '\r') 

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\ndef"
    close $f
    set f [open test1]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.11 {TranslateInputEOL: EOF char} {
    # (*chanPtr->inEofChar != '\0')

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\ndefgh"
    close $f
    set f [open test1]
    fconfigure $f -translation auto -eofchar e
    set x [read $f]
    close $f
    set x
} "abcd\nd"
test io-13.12 {TranslateInputEOL: find EOF char in src} {
    # (*chanPtr->inEofChar != '\0')

    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
    close $f
    set f [open test1]
    fconfigure $f -translation auto -eofchar e
    set x [read $f]
    close $f
    set x
} "\n\n\nab\n\nd"
    
# Test standard handle management. The functions tested are







|



|








|



|






|



|








|



|








|



|








|



|







1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548

    close $f
    set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} {
    # (src >= srcMax)

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [list [read $f] [testchannel queuedcr $f]]
    close $f
    set x
} [list "abcd\n" 1]
test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
    # (*src == '\n')

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\r\ndef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\rdef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.10 {TranslateInputEOL: auto mode: \n} {
    # not (*src == '\r') 

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\ndef"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto
    set x [read $f]
    close $f
    set x
} "abcd\ndef"
test io-13.11 {TranslateInputEOL: EOF char} {
    # (*chanPtr->inEofChar != '\0')

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "abcd\ndefgh"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto -eofchar e
    set x [read $f]
    close $f
    set x
} "abcd\nd"
test io-13.12 {TranslateInputEOL: find EOF char in src} {
    # (*chanPtr->inEofChar != '\0')

    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
    close $f
    set f [open $path(test1)]
    fconfigure $f -translation auto -eofchar e
    set x [read $f]
    close $f
    set x
} "\n\n\nab\n\nd"
    
# Test standard handle management. The functions tested are
1565
1566
1567
1568
1569
1570
1571



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
    set l ""
    lappend l [x eval {fconfigure stdin -buffering}]
    lappend l [x eval {fconfigure stdout -buffering}]
    lappend l [x eval {fconfigure stderr -buffering}]
    interp delete x
    set l
} {line line none}



test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} {
    set f [open test1 w]
    puts $f {
	close stdin
	close stdout
	close stderr
	set f [open test1 r]
	set f2 [open test2 w]
	set f3 [open test3 w]
	puts stdout [gets stdin]
	puts stdout out
	puts stderr err
	close $f
	close $f2
	close $f3
    }
    close $f
    set result [exec [interpreter] test1]
    set f [open test2 r]
    set f2 [open test3 r]
    lappend result [read $f] [read $f2]
    close $f
    close $f2
    set result
} {{
out
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} {
    set f [open test1 w]
    puts $f { close stdin
	close stdout
	close stderr
	set f [open test1 r]
	set f2 [open test2 w]
	set f3 [open test3 w]
	puts stdout [gets stdin]
	puts stdout $f2
	puts stderr $f3
	close $f
	close $f2
	close $f3
    }
    close $f
    set result [exec [interpreter] test1]
    set f [open test2 r]
    set f2 [open test3 r]
    lappend result [read $f] [read $f2]
    close $f
    close $f2
    set result
} {{ close stdin
file1
} {file2







>
>
>
|
|
|



|
|
|






|

|
|
|









|
|
|


|
|
|






|

|
|
|







1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
    set l ""
    lappend l [x eval {fconfigure stdin -buffering}]
    lappend l [x eval {fconfigure stdout -buffering}]
    lappend l [x eval {fconfigure stderr -buffering}]
    interp delete x
    set l
} {line line none}

set path(test3) [makeFile {} test3]

test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
    set f [open $path(test1) w]
    puts $f [format {
	close stdin
	close stdout
	close stderr
	set f  [open "%s" r]
	set f2 [open "%s" w]
	set f3 [open "%s" w]
	puts stdout [gets stdin]
	puts stdout out
	puts stderr err
	close $f
	close $f2
	close $f3
    } $path(test1) $path(test2) $path(test3)]
    close $f
    set result [exec [interpreter] $path(test1)]
    set f  [open $path(test2) r]
    set f2 [open $path(test3) r]
    lappend result [read $f] [read $f2]
    close $f
    close $f2
    set result
} {{
out
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
    set f [open $path(test1) w]
    puts $f [format { close stdin
	close stdout
	close stderr
	set f  [open "%s" r]
	set f2 [open "%s" w]
	set f3 [open "%s" w]
	puts stdout [gets stdin]
	puts stdout $f2
	puts stderr $f3
	close $f
	close $f2
	close $f3
    } $path(test1) $path(test2) $path(test3)]
    close $f
    set result [exec [interpreter] $path(test1)]
    set f  [open $path(test2) r]
    set f2 [open $path(test3) r]
    lappend result [read $f] [read $f2]
    close $f
    close $f2
    set result
} {{ close stdin
file1
} {file2
1652
1653
1654
1655
1656
1657
1658



1659
1660
1661
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
    catch {z eval flush stderr} msg1
    catch {z eval close stderr} msg2
    catch {z eval flush stderr} msg3
    set result [list $msg1 $msg2 $msg3]
    interp delete z
    set result
} {{} {} {can not find channel named "stderr"}}



test io-14.8 {reuse of stdio special channels} {stdio} {
    removeFile script
    removeFile test1
    set f [open script w]
    puts $f {
	close stderr
	set f [open test1 w]
	puts stderr hello
	close $f
	set f [open test1 r]
	puts [gets $f]
    }
    close $f
    set f [open "|[list [interpreter] script]" r]
    set c [gets $f]
    close $f
    set c
} hello

test io-14.9 {reuse of stdio special channels} {stdio} {
    removeFile script
    removeFile test1
    set f [open script w]
    puts $f {

	set f [open test1 w]
	puts $f hello
	close $f
	close stderr
	set f [open "|[list [info nameofexecutable] cat test1]" r]
	puts [gets $f]
    }
    close $f
    set f [open "|[list [interpreter] script]" r]
    set c [gets $f]
    close $f
    set c
} hello

test io-15.1 {Tcl_CreateCloseHandler} {
} {}







>
>
>



|
|

|


|

|

|




>



|

>
|



|



|







1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
    catch {z eval flush stderr} msg1
    catch {z eval close stderr} msg2
    catch {z eval flush stderr} msg3
    set result [list $msg1 $msg2 $msg3]
    interp delete z
    set result
} {{} {} {can not find channel named "stderr"}}

set path(script) [makeFile {} script]

test io-14.8 {reuse of stdio special channels} {stdio} {
    removeFile script
    removeFile test1
    set f [open $path(script) w]
    puts $f [format {
	close stderr
	set f [open "%s" w]
	puts stderr hello
	close $f
	set f [open "%s" r]
	puts [gets $f]
    } $path(test1) $path(test1)]
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    set c [gets $f]
    close $f
    set c
} hello

test io-14.9 {reuse of stdio special channels} {stdio} {
    removeFile script
    removeFile test1
    set f [open $path(script) w]
    puts $f {
        array set path [lindex $argv 0]
	set f [open $path(test1) w]
	puts $f hello
	close $f
	close stderr
	set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
	puts [gets $f]
    }
    close $f
    set f [open "|[list [interpreter] $path(script) [array get path]]" r]
    set c [gets $f]
    close $f
    set c
} hello

test io-15.1 {Tcl_CreateCloseHandler} {
} {}
1742
1743
1744
1745
1746
1747
1748
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
    lappend l [expr [testchannel refcount stderr] - $l1]
    set l
} {0 1 0}

test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile test1
    set l ""
    set f [open test1 w]
    lappend l [lindex [testchannel info $f] 15]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile test1
    set l ""
    set f [open test1 w]
    lappend l [lindex [testchannel info $f] 15]
    interp create x
    interp share "" $f x
    lappend l [lindex [testchannel info $f] 15]
    x eval close $f
    lappend l [lindex [testchannel info $f] 15]
    interp delete x
    lappend l [lindex [testchannel info $f] 15]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 1 2 1 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile test1
    set l ""
    set f [open test1 w]
    lappend l [lindex [testchannel info $f] 15]
    interp create x
    interp share "" $f x
    lappend l [lindex [testchannel info $f] 15]
    interp delete x
    lappend l [lindex [testchannel info $f] 15]
    close $f







|













|




















|







1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
    lappend l [expr [testchannel refcount stderr] - $l1]
    set l
} {0 1 0}

test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile test1
    set l ""
    set f [open $path(test1) w]
    lappend l [lindex [testchannel info $f] 15]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile test1
    set l ""
    set f [open $path(test1) w]
    lappend l [lindex [testchannel info $f] 15]
    interp create x
    interp share "" $f x
    lappend l [lindex [testchannel info $f] 15]
    x eval close $f
    lappend l [lindex [testchannel info $f] 15]
    interp delete x
    lappend l [lindex [testchannel info $f] 15]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 1 2 1 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile test1
    set l ""
    set f [open $path(test1) w]
    lappend l [lindex [testchannel info $f] 15]
    interp create x
    interp share "" $f x
    lappend l [lindex [testchannel info $f] 15]
    interp delete x
    lappend l [lindex [testchannel info $f] 15]
    close $f
1799
1800
1801
1802
1803
1804
1805
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
} 0

test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
    eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
    removeFile test1
    set f [open test1 w]
    set x [eof $f]
    close $f
    set x
} 0
test io-19.3 {Tcl_GetChannel, channel not found} {
    list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
    removeFile test1
    set f [open test1 w]
    set l ""
    lappend l [eof $f]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 0 [format "can not find channel named \"%s\"" $f]]
} 0

test io-20.1 {Tcl_CreateChannel: initial settings} {
	set a [open test2 w]
    set old [encoding system]
    encoding system ascii
    set f [open test1 w]
    set x [fconfigure $f -encoding]
    close $f
    encoding system $old
	close $a
    set x
} {ascii}    
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
    set f [open test1 w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto cr}}



test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
    set f [open script w]
    puts $f {
	close stdout
	set f1 [open stdout w]
	fconfigure $f1 -buffersize 777
	puts stderr [fconfigure stdout -buffersize]
    }
    close $f
    set f [open "|[list [interpreter] script]"]
    catch {close $f} msg
    set msg
} {777}
	
test io-21.1 {CloseChannelsOnExit} {
} {}
    
# Test management of attributes associated with a channel, such as
# its default translation, its name and type, etc. The functions
# tested in this group are Tcl_GetChannelName,
# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
# not tested because files do not use the instance data.

test io-22.1 {Tcl_GetChannelMode} {
    # Not used anywhere in Tcl.
} {}

test io-23.1 {Tcl_GetChannelName} {testchannel} {
    removeFile test1
    set f [open test1 w]
    set n [testchannel name $f]
    close $f
    string compare $n $f
} 0

test io-24.1 {Tcl_GetChannelType} {testchannel} {
    removeFile test1
    set f [open test1 w]
    set t [testchannel type $f]
    close $f
    string compare $t file
} 0

test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    puts $f "1234567890\n098765432"
    close $f
    set f [open test1 r]
    gets $f
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {10 11}
test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [tell $f]
    flush $f
    lappend l [testchannel outputbuffered $f]







|









|













|


|







|





|





|




>
>
>

|
|

|


|

|



















|







|






|



|









|







1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
} 0

test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
    eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
    removeFile test1
    set f [open $path(test1) w]
    set x [eof $f]
    close $f
    set x
} 0
test io-19.3 {Tcl_GetChannel, channel not found} {
    list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    set l ""
    lappend l [eof $f]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 0 [format "can not find channel named \"%s\"" $f]]
} 0

test io-20.1 {Tcl_CreateChannel: initial settings} {
	set a [open $path(test2) w]
    set old [encoding system]
    encoding system ascii
    set f [open $path(test1) w]
    set x [fconfigure $f -encoding]
    close $f
    encoding system $old
	close $a
    set x
} {ascii}    
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto cr}}

set path(stdout) [makeFile {} stdout]

test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
    set f [open $path(script) w]
    puts $f [format {
	close stdout
	set f1 [open "%s" w]
	fconfigure $f1 -buffersize 777
	puts stderr [fconfigure stdout -buffersize]
    } $path(stdout)]
    close $f
    set f [open "|[list [interpreter] $path(script)]"]
    catch {close $f} msg
    set msg
} {777}
	
test io-21.1 {CloseChannelsOnExit} {
} {}
    
# Test management of attributes associated with a channel, such as
# its default translation, its name and type, etc. The functions
# tested in this group are Tcl_GetChannelName,
# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
# not tested because files do not use the instance data.

test io-22.1 {Tcl_GetChannelMode} {
    # Not used anywhere in Tcl.
} {}

test io-23.1 {Tcl_GetChannelName} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    set n [testchannel name $f]
    close $f
    string compare $n $f
} 0

test io-24.1 {Tcl_GetChannelType} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    set t [testchannel type $f]
    close $f
    string compare $t file
} 0

test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f "1234567890\n098765432"
    close $f
    set f [open $path(test1) r]
    gets $f
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {10 11}
test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [tell $f]
    flush $f
    lappend l [testchannel outputbuffered $f]
1936
1937
1938
1939
1940
1941
1942
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
    close $f
} {}    

# Test flushing. The functions tested here are FlushChannel.

test io-27.1 {FlushChannel, no output buffered} {
    removeFile test1
    set f [open test1 w]
    flush $f
    set s [file size test1]
    close $f
    set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    puts $f hello
    lappend l [file size test1]
    flush $f
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    puts $f hello
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    fconfigure $f -buffersize 60
    set l ""
    lappend l [file size test1]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size test1]
    flush $f
    lappend l [file size test1]
    close $f
    set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
	{unixOrPc} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffersize 60 -eofchar {}
    set l ""
    lappend l [file size test1]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size test1]
    close $f
    lappend l [file size test1]
    set l
} {0 60 72}




test io-27.6 {FlushChannel, async flushing, async close} \
	{stdio asyncPipeClose } {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {
	set f [open output w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
	    after 20
	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    }
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
    }
    set f [open output w]
    close $f
    set f [open "|[list [interpreter] pipe]" w]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size output] < 65536) && ($counter < 1000)} {
        incr counter
        after 20
        update
    }
    if {$counter == 1000} {
        set result "file size only [file size output]"
    } else {
        set result ok
    }
} ok

# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.

test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
    removeFile test1
    set f [open test1 w]
    interp create x
    interp share "" $f x
    set l ""
    lappend l [testchannel refcount $f]
    x eval close $f
    interp delete x
    lappend l [testchannel refcount $f]
    close $f
    set l
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
    removeFile test1
    set f [open test1 w]
    interp create x
    interp share "" $f x
    puts -nonewline $f abc
    close $f
    x eval puts $f def
    x eval close $f
    interp delete x
    set f [open test1 r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
	{stdio asyncPipeClose nonPortable} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
	# error "invalid file".

	fconfigure stdout -eofchar {}
	fconfigure stderr -eofchar {}

	set f [open output w]
	fconfigure $f -translation lf -buffering none
	for {set x 0} {$x < 20} {incr x} {
	    after 20
	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    }
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
    }
    set f [open output w]
    close $f
    set f [open "|[list [interpreter] pipe]" r+]
    fconfigure $f -blocking off -eofchar {}

    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size output] < 20480) && ($counter < 1000)} {
        incr counter
        after 20
        update
    }
    if {$counter == 1000} {
        set result probably_broken
    } else {
        set result ok
    }
} ok
test io-28.4 {Tcl_Close} {testchannel} {
    removeFile test1
    set l ""
    lappend l [lsort [testchannel open]]
    set f [open test1 w]
    lappend l [lsort [testchannel open]]
    close $f
    lappend l [lsort [testchannel open]]
    set x [list $consoleFileNames \
		[lsort [eval list $consoleFileNames $f]] \
		$consoleFileNames]
    string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel} {
    removeFile script
    set f [open script w]
    puts $f {
	close stdin
	puts [testchannel open]
    }
    close $f
    set f [open "|[list [interpreter] script]" r]
    set l [gets $f]
    close $f
    set l
} {file1 file2}

test io-29.1 {Tcl_WriteChars, channel not writable} {
    list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -eofchar {}
    puts -nonewline $f ""
    close $f
    file size test1
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -eofchar {}
    puts -nonewline $f hello
    close $f
    file size test1
} 5
test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffering full -eofchar {}
    puts $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    close $f
    set l
} {6 0 0 6}
test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffering line -eofchar {}
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    close $f
    set l
} {5 0 0 11}
test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffering none -eofchar {}
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    close $f
    set l
} {0 5 0 11}

test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffering full -eofchar {}
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    close $f
    set l
} {5 0 11 0 0 11}
test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -buffering line
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size test1]
    close $f
    set l
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
    list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    set f2 [open longfile r]
    for {set x 0} {$x < 10} {incr x} {
	puts $f1 [gets $f2]
    }
    close $f2
    close $f1
    file size test1
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -eofchar {}
    set f2 [open longfile r]
    for {set x 0} {$x < 10} {incr x} {
	puts -nonewline $f1 [gets $f2]
    }
    close $f1
    close $f2
    file size test1
} 377
test io-29.12 {Tcl_WriteChars on a pipe} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	set f1 [open longfile r]
	for {set x 0} {$x < 10} {incr x} {
	    puts [gets $f1]
	}
    }
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r]
    set f2 [open longfile r]
    set y ok
    for {set x 0} {$x < 10} {incr x} {
	set l1 [gets $f1]
	set l2 [gets $f2]
	if {"$l1" != "$l2"} {
	    set y broken
	}
    }
    close $f1
    close $f2
    set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	puts [gets stdin]
	puts [gets stdin]
    }
    close $f1
    set y ok
    set f1 [open "|[list [interpreter] pipe]" r+]
    fconfigure $f1 -buffering line
    set f2 [open longfile r]
    set line [gets $f2]
    puts $f1 $line
    set backline [gets $f1]
    if {"$line" != "$backline"} {
	set y broken
    }
    set line [gets $f2]
    puts $f1 $line
    set backline [gets $f1]
    if {"$line" != "$backline"} {
	set y broken
    }
    close $f1
    close $f2
    set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
    removeFile test3
    set f [open test3 w]
    puts -nonewline $f "Text1"
    puts -nonewline $f " Text 2"
    puts $f " Text 3"
    close $f
    set f [open test3 r]
    set x [gets $f]
    close $f
    set x
} {Text1 Text 2 Text 3}
test io-29.15 {Tcl_Flush, channel not open for writing} {
    removeFile test1
    set fd [open test1 w]
    close $fd
    set fd [open test1 r]
    set x [list [catch {flush $fd} msg] $msg]
    close $fd
    string compare $x \
	[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio} {
    set fd [open "|[list [interpreter] cat longfile]" r]
    set x [list [catch {flush $fd} msg] $msg]
    catch {close $fd}
    string compare $x \
	[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf
    puts $f1 hello
    puts $f1 hello
    puts $f1 hello
    flush $f1
    set x [file size test1]
    close $f1
    set x
} 18
test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
    removeFile test1
    set x ""
    set f1 [open test1 w]
    fconfigure $f1 -translation lf
    puts $f1 hello
    puts $f1 hello
    puts $f1 hello
    flush $f1
    lappend x [file size test1]
    puts $f1 hello
    flush $f1
    lappend x [file size test1]
    puts $f1 hello
    flush $f1
    lappend x [file size test1]
    close $f1
    set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    set x ""
    puts $f1 hello
    puts $f1 hello
    puts $f1 hello
    flush $f1
    lappend x [file size test1]
    puts $f1 hello
    flush $f1
    lappend x [file size test1]
    puts $f1 hello
    close $f1
    lappend x [file size test1]
    set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    for {set x 0} {$x < 100} {incr x} {
      puts $f1 $line
    }
    set z ""
    lappend z [file size test1]
    for {set x 0} {$x < 100} {incr x} {
	puts $f1 $line
    }
    lappend z [file size test1]
    close $f1
    lappend z [file size test1]
    set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {set x [read stdin 6]}
    puts $f1 {set cnt [string length $x]}
    puts $f1 {puts "read $cnt characters"}
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    puts $f1 hello
    flush $f1
    set x [gets $f1]
    catch {close $f1}
    set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	fconfigure stdout -buffering full
	puts hello
	puts hello
	flush stdout
	gets stdin
	puts bye
	flush stdout
    }
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    set x ""
    lappend x [gets $f1]
    lappend x [gets $f1]
    puts $f1 hello
    flush $f1
    lappend x [gets $f1]
    close $f1
    set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	puts hello
	puts hello
	gets stdin
	puts bye
    }
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    set x ""
    lappend x [gets $f1]
    lappend x [gets $f1]
    puts $f1 hello
    flush $f1
    lappend x [gets $f1]
    close $f1
    set x
} {hello hello bye}
test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
    set f [open test3 w]
    puts $f "Line 1"
    puts $f "Line 2"
    set f2 [open test3]
    set x {}
    lappend x [read -nonewline $f2]
    close $f2
    flush $f
    set f2 [open test3]
    lappend x [read -nonewline $f2]
    close $f2
    close $f
    set x
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} {
    removeFile test3
    set f [open "|[list [interpreter] cat | [interpreter] cat > test3]" w]
    puts $f "Line 1"
    puts $f "Line 2"
    close $f
    after 100
    set f [open test3 r]
    set x [read $f]
    close $f
    set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} {
    set f [open "|[list cat -u]" r+]
    puts $f "Line1"
    flush $f
    set x [gets $f]
    close $f
    set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} {stdio} {
    removeFile pipe
    set f [open pipe w]
    puts $f {exit}
    close $f
    set f [open "|[list [interpreter] pipe]" r+]
    gets $f
    puts $f output
    after 50
    #
    # The flush below will get a SIGPIPE. This is an expected part of
    # test and indicates that the test operates correctly. If you run
    # this test under a debugger, the signal will by intercepted unless







|

|





|



|

|

|




|



|

|




|



|



|

|






|


|



|

|


>
>
>
>




|
|
|






|





|

|




|





|









|












|







|








|









|












|







|














|










|





|










|



|



|



|



|




|


|





|




|


|





|




|


|






|




|


|


|





|




|


|


|


|








|

|





|



|

|





|




|
|
|



|

|
|















|






|

|


















|




|






|

|














|





|






|





|


|


|





|






|


|


|




|






|



|

|




|




|








|










|











|







|










|


|




|







|




|














|


|







1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
    close $f
} {}    

# Test flushing. The functions tested here are FlushChannel.

test io-27.1 {FlushChannel, no output buffered} {
    removeFile test1
    set f [open $path(test1) w]
    flush $f
    set s [file size $path(test1)]
    close $f
    set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    puts $f hello
    lappend l [file size $path(test1)]
    flush $f
    lappend l [file size $path(test1)]
    close $f
    lappend l [file size $path(test1)]
    set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    puts $f hello
    lappend l [file size $path(test1)]
    close $f
    lappend l [file size $path(test1)]
    set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    fconfigure $f -buffersize 60
    set l ""
    lappend l [file size $path(test1)]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size $path(test1)]
    flush $f
    lappend l [file size $path(test1)]
    close $f
    set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
	{unixOrPc} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffersize 60 -eofchar {}
    set l ""
    lappend l [file size $path(test1)]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size $path(test1)]
    close $f
    lappend l [file size $path(test1)]
    set l
} {0 60 72}

set path(pipe)   [makeFile {} pipe]
set path(output) [makeFile {} output]

test io-27.6 {FlushChannel, async flushing, async close} \
	{stdio asyncPipeClose } {
    removeFile pipe
    removeFile output
    set f [open $path(pipe) w]
    puts $f [format {
	set f [open "%s" w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
	    after 20
	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    } $path(output)]
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
    }
    set f [open $path(output) w]
    close $f
    set f [open "|[list [interpreter] $path(pipe)]" w]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
        incr counter
        after 20
        update
    }
    if {$counter == 1000} {
        set result "file size only [file size $path(output)]"
    } else {
        set result ok
    }
} ok

# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.

test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    interp create x
    interp share "" $f x
    set l ""
    lappend l [testchannel refcount $f]
    x eval close $f
    interp delete x
    lappend l [testchannel refcount $f]
    close $f
    set l
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
    removeFile test1
    set f [open $path(test1) w]
    interp create x
    interp share "" $f x
    puts -nonewline $f abc
    close $f
    x eval puts $f def
    x eval close $f
    interp delete x
    set f [open $path(test1) r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
	{stdio asyncPipeClose nonPortable} {
    removeFile pipe
    removeFile output
    set f [open $path(pipe) w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
	# error "invalid file".

	fconfigure stdout -eofchar {}
	fconfigure stderr -eofchar {}

	set f [open $path(output) w]
	fconfigure $f -translation lf -buffering none
	for {set x 0} {$x < 20} {incr x} {
	    after 20
	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    }
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
    }
    set f [open $path(output) w]
    close $f
    set f [open "|[list [interpreter] pipe]" r+]
    fconfigure $f -blocking off -eofchar {}

    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 20480) && ($counter < 1000)} {
        incr counter
        after 20
        update
    }
    if {$counter == 1000} {
        set result probably_broken
    } else {
        set result ok
    }
} ok
test io-28.4 {Tcl_Close} {testchannel} {
    removeFile test1
    set l ""
    lappend l [lsort [testchannel open]]
    set f [open $path(test1) w]
    lappend l [lsort [testchannel open]]
    close $f
    lappend l [lsort [testchannel open]]
    set x [list $consoleFileNames \
		[lsort [eval list $consoleFileNames $f]] \
		$consoleFileNames]
    string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	close stdin
	puts [testchannel open]
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    set l [gets $f]
    close $f
    set l
} {file1 file2}

test io-29.1 {Tcl_WriteChars, channel not writable} {
    list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -eofchar {}
    puts -nonewline $f ""
    close $f
    file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -eofchar {}
    puts -nonewline $f hello
    close $f
    file size $path(test1)
} 5
test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffering full -eofchar {}
    puts $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    close $f
    set l
} {6 0 0 6}
test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffering line -eofchar {}
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    close $f
    set l
} {5 0 0 11}
test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffering none -eofchar {}
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    close $f
    set l
} {0 5 0 11}

test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffering full -eofchar {}
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    close $f
    set l
} {5 0 11 0 0 11}
test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffering line
    puts -nonewline $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    puts $f hello
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [file size $path(test1)]
    close $f
    set l
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
    list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    set f2 [open $path(longfile) r]
    for {set x 0} {$x < 10} {incr x} {
	puts $f1 [gets $f2]
    }
    close $f2
    close $f1
    file size $path(test1)
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -eofchar {}
    set f2 [open $path(longfile) r]
    for {set x 0} {$x < 10} {incr x} {
	puts -nonewline $f1 [gets $f2]
    }
    close $f1
    close $f2
    file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 [format {
	set f1 [open "%s" r]
	for {set x 0} {$x < 10} {incr x} {
	    puts [gets $f1]
	}
    } $path(longfile)]
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r]
    set f2 [open $path(longfile) r]
    set y ok
    for {set x 0} {$x < 10} {incr x} {
	set l1 [gets $f1]
	set l2 [gets $f2]
	if {"$l1" != "$l2"} {
	    set y broken
	}
    }
    close $f1
    close $f2
    set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {
	puts [gets stdin]
	puts [gets stdin]
    }
    close $f1
    set y ok
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f1 -buffering line
    set f2 [open $path(longfile) r]
    set line [gets $f2]
    puts $f1 $line
    set backline [gets $f1]
    if {"$line" != "$backline"} {
	set y broken
    }
    set line [gets $f2]
    puts $f1 $line
    set backline [gets $f1]
    if {"$line" != "$backline"} {
	set y broken
    }
    close $f1
    close $f2
    set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
    removeFile test3
    set f [open $path(test3) w]
    puts -nonewline $f "Text1"
    puts -nonewline $f " Text 2"
    puts $f " Text 3"
    close $f
    set f [open $path(test3) r]
    set x [gets $f]
    close $f
    set x
} {Text1 Text 2 Text 3}
test io-29.15 {Tcl_Flush, channel not open for writing} {
    removeFile test1
    set fd [open $path(test1) w]
    close $fd
    set fd [open $path(test1) r]
    set x [list [catch {flush $fd} msg] $msg]
    close $fd
    string compare $x \
	[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio} {
    set fd [open "|[list [interpreter] cat longfile]" r]
    set x [list [catch {flush $fd} msg] $msg]
    catch {close $fd}
    string compare $x \
	[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf
    puts $f1 hello
    puts $f1 hello
    puts $f1 hello
    flush $f1
    set x [file size $path(test1)]
    close $f1
    set x
} 18
test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
    removeFile test1
    set x ""
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf
    puts $f1 hello
    puts $f1 hello
    puts $f1 hello
    flush $f1
    lappend x [file size $path(test1)]
    puts $f1 hello
    flush $f1
    lappend x [file size $path(test1)]
    puts $f1 hello
    flush $f1
    lappend x [file size $path(test1)]
    close $f1
    set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    set x ""
    puts $f1 hello
    puts $f1 hello
    puts $f1 hello
    flush $f1
    lappend x [file size $path(test1)]
    puts $f1 hello
    flush $f1
    lappend x [file size $path(test1)]
    puts $f1 hello
    close $f1
    lappend x [file size $path(test1)]
    set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    for {set x 0} {$x < 100} {incr x} {
      puts $f1 $line
    }
    set z ""
    lappend z [file size $path(test1)]
    for {set x 0} {$x < 100} {incr x} {
	puts $f1 $line
    }
    lappend z [file size $path(test1)]
    close $f1
    lappend z [file size $path(test1)]
    set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {set x [read stdin 6]}
    puts $f1 {set cnt [string length $x]}
    puts $f1 {puts "read $cnt characters"}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    flush $f1
    set x [gets $f1]
    catch {close $f1}
    set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {
	fconfigure stdout -buffering full
	puts hello
	puts hello
	flush stdout
	gets stdin
	puts bye
	flush stdout
    }
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set x ""
    lappend x [gets $f1]
    lappend x [gets $f1]
    puts $f1 hello
    flush $f1
    lappend x [gets $f1]
    close $f1
    set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {
	puts hello
	puts hello
	gets stdin
	puts bye
    }
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set x ""
    lappend x [gets $f1]
    lappend x [gets $f1]
    puts $f1 hello
    flush $f1
    lappend x [gets $f1]
    close $f1
    set x
} {hello hello bye}
test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
    set f [open $path(test3) w]
    puts $f "Line 1"
    puts $f "Line 2"
    set f2 [open $path(test3)]
    set x {}
    lappend x [read -nonewline $f2]
    close $f2
    flush $f
    set f2 [open $path(test3)]
    lappend x [read -nonewline $f2]
    close $f2
    close $f
    set x
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} {
    removeFile test3
    set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
    puts $f "Line 1"
    puts $f "Line 2"
    close $f
    after 100
    set f [open $path(test3) r]
    set x [read $f]
    close $f
    set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} {
    set f [open "|[list cat -u]" r+]
    puts $f "Line1"
    flush $f
    set x [gets $f]
    close $f
    set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} {stdio} {
    removeFile pipe
    set f [open $path(pipe) w]
    puts $f {exit}
    close $f
    set f [open "|[list [interpreter] $path(pipe)]" r+]
    gets $f
    puts $f output
    after 50
    #
    # The flush below will get a SIGPIPE. This is an expected part of
    # test and indicates that the test operates correctly. If you run
    # this test under a debugger, the signal will by intercepted unless
2536
2537
2538
2539
2540
2541
2542
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
	}
    }
    regsub {".*":} $x {"":} x
    string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    puts $f hello\nthere\nand\nhere
    flush $f
    set s [file size test1]
    close $f
    set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar {}
    puts $f hello\nthere\nand\nhere
    close $f
    file size test1
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar {}
    puts $f hello\nthere\nand\nhere
    close $f
    file size test1
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {set f [open output w]}
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
    puts $f $x
    puts $f {  puts -nonewline $f [read stdin 4096]}
    puts $f {  flush $f}
    puts $f "}"
    puts $f {close $f}
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
	set x "$x$x"
    }
    set f [open output w]
    close $f
    set f [open "|[list [interpreter] pipe]" r+]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size output] < 65536) && ($counter < 1000)} {
	incr counter
	after 5
	update
    }
    if {$counter == 1000} {
	set result "file size only [file size output]"
    } else {
	set result ok
    }
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
	{stdio asyncPipeClose} {
    removeFile pipe
    removeFile output
    set f [open pipe w]
    puts $f {set f [open output w]}
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
    puts $f $x
    puts $f {  after 20}
    puts $f {  puts -nonewline $f [read stdin 1024]}
    puts $f {  flush $f}
    puts $f "}"
    puts $f {close $f}
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
	set x "$x$x"
    }
    set f [open output w]
    close $f
    set f [open "|[list [interpreter] pipe]" r+]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size output] < 65536) && ($counter < 1000)} {
	incr counter
	after 20
	update
    }
    if {$counter == 1000} {
	set result "file size only [file size output]"
    } else {
	set result ok
    }
} ok
test io-29.33 {Tcl_Flush, implicit flush on exit} {stdio} {
    set f [open script w]
    puts $f {
	set f [open test1 w]
	fconfigure $f -translation lf
	puts $f hello
	puts $f bye
	puts $f strange
    }
    close $f
    exec [interpreter] script
    set f [open test1 r]
    set r [read $f]
    close $f
    set r
} "hello\nbye\nstrange\n"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
    set c 0
    variable x running







|



|





|



|



|



|




|
|













|

|




|





|








|
|














|

|




|





|




|
|
|
|




|

|
|







2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
	}
    }
    regsub {".*":} $x {"":} x
    string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f hello\nthere\nand\nhere
    flush $f
    set s [file size $path(test1)]
    close $f
    set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    puts $f hello\nthere\nand\nhere
    close $f
    file size $path(test1)
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar {}
    puts $f hello\nthere\nand\nhere
    close $f
    file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio} {
    removeFile pipe
    removeFile output
    set f [open $path(pipe) w]
    puts $f [format {set f [open "%s" w]} $path(output)]
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
    puts $f $x
    puts $f {  puts -nonewline $f [read stdin 4096]}
    puts $f {  flush $f}
    puts $f "}"
    puts $f {close $f}
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
	set x "$x$x"
    }
    set f [open $path(output) w]
    close $f
    set f [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
	incr counter
	after 5
	update
    }
    if {$counter == 1000} {
	set result "file size only [file size $path(output)]"
    } else {
	set result ok
    }
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
	{stdio asyncPipeClose} {
    removeFile pipe
    removeFile output
    set f [open $path(pipe) w]
    puts $f [format {set f [open "%s" w]} $path(output)]
    puts $f {fconfigure $f -translation lf}
    set x [list while {![eof stdin]}]
    set x "$x {"
    puts $f $x
    puts $f {  after 20}
    puts $f {  puts -nonewline $f [read stdin 1024]}
    puts $f {  flush $f}
    puts $f "}"
    puts $f {close $f}
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
	set x "$x$x"
    }
    set f [open $path(output) w]
    close $f
    set f [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
	incr counter
	after 20
	update
    }
    if {$counter == 1000} {
	set result "file size only [file size $path(output)]"
    } else {
	set result ok
    }
} ok
test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
    set f [open $path(script) w]
    puts $f [format {
	set f [open "%s" w]
	fconfigure $f -translation lf
	puts $f hello
	puts $f bye
	puts $f strange
    } $path(test1)]
    close $f
    exec [interpreter] $path(script)
    set f [open $path(test1) r]
    set r [read $f]
    close $f
    set r
} "hello\nbye\nstrange\n"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
    set c 0
    variable x running
2733
2734
2735
2736
2737
2738
2739
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
    interp delete y
} ""

# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.

test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf
    set x [read $f]
    close $f
    set x
} "hello\rthere\rand\rhere\r"
test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x 
} "hello\rthere\rand\rhere\r"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf
    set x [read $f]
    close $f
    set x
} "hello\r\nthere\r\nand\r\nhere\r\n"
test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "hello\n\nthere\n\nand\n\nhere\n\n"
test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    set c [read $f]
    set x [fconfigure $f -translation]
    close $f
    list $c $x
} {{hello
there
and
here
} auto}
test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    set c [read $f]
    set x [fconfigure $f -translation]
    close $f
    list $c $x
} {{hello
there
and
here
} auto}
test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    set c [read $f]
    set x [fconfigure $f -translation]
    close $f
    list $c $x
} {{hello
there
and
here
} auto}

test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto
    set c [read $f]
    close $f
    string length $c
} [expr 700*15+1]

test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set c [read $f]
    close $f
    string length $c
} [expr 700*15+1]

test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto
    set c [read $f]
    close $f
    set c
} {hello
there
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\nand\rhere\n\x1a
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set c [read $f]
    close $f
    set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -eofchar \x1a -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set c [read $f]
    close $f
    set c
} {hello
there
and
here
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar {}
    set l ""
    set x [gets $f]
    lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar {}
    set l ""
    set x [gets $f]
    lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {0 1 {} 1}
test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}

# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.

test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 6 auto there 12 auto}
test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 6 auto there 12 auto}
test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 7 auto there 14 auto}
test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 6 lf there 12 lf}
test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 cr 1 {} 21 cr 1}
test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {hello 6 cr 0 there 12 cr 0}
test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 lf 1 {} 21 lf 1}
test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {hello 7 crlf 0 there 14 crlf 0}
test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {hello 6 cr 0 6 13 cr 0}
test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {6 7 lf 0 6 14 lf 0}
test io-31.13 {binary mode is synonym of lf mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation binary
    set x [fconfigure $f -translation]
    close $f
    set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts $f hello\nthere\rand\r\nhere
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\rand\r\nhere\r
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\rand\r\nhere\n
    close $f
    set f [open test1 r]
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\rand\r\nhere\r\n
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "hello\nthere\nand\rhere\n\%c" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -eofchar \x1a -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open test1 r]
    fconfigure $f -translation crlf 
    set c ""
    while {[gets $f line] >= 0} {
	append c $line\n
    }
    close $f
    string length $c
} [expr 700*15+1]
test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open test1 r]
    fconfigure $f -translation auto
    set c ""
    while {[gets $f line] >= 0} {
	append c $line\n
    }
    close $f
    string length $c
} [expr 700*15+1]


# Test Tcl_Read and buffering.

test io-32.1 {Tcl_Read, channel not readable} {
    list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test io-32.2 {Tcl_Read, zero byte count} {
    read stdin 0
} ""
test io-32.3 {Tcl_Read, negative byte count} {
    set f [open longfile r]
    set l [list [catch {read $f -1} msg] $msg]
    close $f
    set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-32.4 {Tcl_Read, positive byte count} {
    set f [open longfile r]
    set x [read $f 1024]
    set s [string length $x]
    unset x
    close $f
    set s
} 1024
test io-32.5 {Tcl_Read, multiple buffers} {
    set f [open longfile r]
    fconfigure $f -buffersize 100
    set x [read $f 1024]
    set s [string length $x]
    unset x
    close $f
    set s
} 1024
test io-32.6 {Tcl_Read, very large read} {
    set f1 [open longfile r]
    set z [read $f1 1000000]
    close $f1
    set l [string length $z]
    set x ok
    set z [file size longfile]
    if {$z != $l} {
	set x broken
    }
    set x
} ok
test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
    set f1 [open longfile r]
    fconfigure $f1 -blocking off
    set z [read $f1 20]
    close $f1
    set l [string length $z]
    set x ok
    if {$l != 20} {
	set x broken
    }
    set x
} ok
test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
    set f1 [open longfile r]
    fconfigure $f1 -blocking off
    set z [read $f1 1000000]
    close $f1
    set x ok
    set l [string length $z]
    set z [file size longfile]
    if {$z != $l} {
	set x broken
    }
    set x
} ok
test io-32.9 {Tcl_Read, read to end of file} {
    set f1 [open longfile r]
    set z [read $f1]
    close $f1
    set l [string length $z]
    set x ok
    set z [file size longfile]
    if {$z != $l} {
	set x broken
    }
    set x
} ok
test io-32.10 {Tcl_Read from a pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    puts $f1 hello
    flush $f1
    set x [read $f1]
    close $f1
    set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {puts [gets stdin]}
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    puts $f1 hello
    flush $f1
    set x ""
    lappend x [read $f1 6]
    puts $f1 hello
    flush $f1
    lappend x [read $f1]
    close $f1
    set x
} {{hello
} {hello
}}
test io-32.12 {Tcl_Read, -nonewline} {
    removeFile test1
    set f1 [open test1 w]
    puts $f1 hello
    puts $f1 bye
    close $f1
    set f1 [open test1 r]
    set c [read -nonewline $f1]
    close $f1
    set c
} {hello
bye}
test io-32.13 {Tcl_Read, -nonewline} {
    removeFile test1
    set f1 [open test1 w]
    puts $f1 hello
    puts $f1 bye
    close $f1
    set f1 [open test1 r]
    set c [read -nonewline $f1]
    close $f1
    list [string length $c] $c
} {9 {hello
bye}}
test io-32.14 {Tcl_Read, reading in small chunks} {
    removeFile test1
    set f [open test1 w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open test1]
    set x [list [read $f 1] [read $f 2] [read $f]]
    close $f
    set x
} {T wo { lines: this one
and this one
}}
test io-32.15 {Tcl_Read, asking for more input than available} {
    removeFile test1
    set f [open test1 w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open test1]
    set x [read $f 100]
    close $f
    set x
} {Two lines: this one
and this one
}
test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
    removeFile test1
    set f [open test1 w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open test1]
    set x [read -nonewline $f]
    close $f
    set x
} {Two lines: this one
and this one}

# Test Tcl_Gets.

test io-33.1 {Tcl_Gets, reading what was written} {
    removeFile test1
    set f1 [open test1 w]
    set y "first line"
    puts $f1 $y
    close $f1
    set f1 [open test1 r]
    set x [gets $f1]
    set z ok
    if {"$x" != "$y"} {
	set z broken
    }
    close $f1
    set z
} ok
test io-33.2 {Tcl_Gets into variable} {
    set f1 [open longfile r]
    set c [gets $f1 x]
    set l [string length x]
    set z ok
    if {$l != $l} {
	set z broken
    }
    close $f1
    set z
} ok
test io-33.3 {Tcl_Gets from pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    puts $f1 hello
    flush $f1
    set x [gets $f1]
    close $f1
    set z ok
    if {"$x" != "hello"} {
	set z broken
    }
    set z
} ok
test io-33.4 {Tcl_Gets with long line} {
    removeFile test3
    set f [open test3 w]
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    close $f
    set f [open test3]
    set x [gets $f]
    close $f
    set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.5 {Tcl_Gets with long line} {
    set f [open test3]
    set x [gets $f y]
    close $f
    list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.6 {Tcl_Gets and end of file} {
    removeFile test3
    set f [open test3 w]
    puts -nonewline $f "Test1\nTest2"
    close $f
    set f [open test3]
    set x {}
    set y {}
    lappend x [gets $f y] $y
    set y {}
    lappend x [gets $f y] $y
    set y {}
    lappend x [gets $f y] $y
    close $f
    set x
} {5 Test1 5 Test2 -1 {}}
test io-33.7 {Tcl_Gets and bad variable} {
    set f [open test3 w]
    puts $f "Line 1"
    puts $f "Line 2"
    close $f
    catch {unset x}
    set x 24
    set f [open test3 r]
    set result [list [catch {gets $f x(0)} msg] $msg]
    close $f
    set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
    set f [open test3 w]
    fconfigure $f -translation lf -eofchar {}
    set x ""
    for {set y 0} {$y < 99} {incr y} {set x "a$x"}
    for {set y 0} {$y < 100} {incr y} {puts $f $x}
    close $f
    set f [open test3 r]
    fconfigure $f -translation lf
    for {set y 0} {$y < 100} {incr y} {gets $f}
    close $f
    set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
    set f [open test3 w]
    fconfigure $f -translation lf -eofchar {}
    set x ""
    for {set y 0} {$y < 99} {incr y} {set x "a$x"}
    for {set y 0} {$y < 200} {incr y} {puts $f $x}
    close $f
    set f [open test3 r]
    fconfigure $f -translation lf
    for {set y 0} {$y < 200} {incr y} {gets $f}
    close $f
    set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
    set f [open test3 w]
    fconfigure $f -translation lf -eofchar {}
    set x ""
    for {set y 0} {$y < 99} {incr y} {set x "a$x"}
    for {set y 0} {$y < 300} {incr y} {puts $f $x}
    close $f
    set f [open test3 r]
    fconfigure $f -translation lf
    for {set y 0} {$y < 300} {incr y} {gets $f}
    close $f
    set y
} 300

# Test Tcl_Seek and Tcl_Tell.

test io-34.1 {Tcl_Seek to current position at start of file} {
    set f1 [open longfile r]
    seek $f1 0 current
    set c [tell $f1]
    close $f1
    set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 10 start
    set c [tell $f1]
    close $f1
    set c
} 10
test io-34.3 {Tcl_Seek to end of file} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 0 end
    set c [tell $f1]
    close $f1
    set c
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 -10 end
    set c [tell $f1]
    close $f1
    set c
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 10 current
    seek $f1 10 current
    set c [tell $f1]
    close $f1
    set c
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 -10 end
    set c [tell $f1]
    set r [read $f1]
    close $f1
    list $c $r
} {44 {rstuvwxyz
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 -10 end
    set c1 [tell $f1]
    set r1 [read $f1 5]
    seek $f1 0 current
    set c2 [tell $f1]
    close $f1
    list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} {stdio} {
    set f1 [open "|[list [interpreter]]" r+]
    set x [list [catch {seek $f1 0 current} msg] $msg]
    close $f1
    regsub {".*":} $x {"":} x
    string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
    removeFile test3
    set f [open test3 w]
    fconfigure $f -eofchar {}
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    close $f
    set f [open test3 RDWR]
    set x [read $f 1]
    seek $f 3
    lappend x [read $f 1]
    seek $f 0 start
    lappend x [read $f 1]
    seek $f 10 current
    lappend x [read $f 1]
    seek $f -2 end
    lappend x [read $f 1]
    seek $f 50 end
    lappend x [read $f 1]
    seek $f 1
    lappend x [read $f 1]
    close $f
    set x
} {a d a l Y {} b}



test io-34.10 {Tcl_Seek testing flushing of buffered input} {
    set f [open test3 w]
    fconfigure $f -translation lf
    puts $f xyz\n123
    close $f
    set f [open test3 r+]
    fconfigure $f -translation lf
    set x [gets $f]
    seek $f 0 current
    puts $f 456
    close $f
    list $x [viewFile test3]
} "xyz {xyz
456}"
test io-34.11 {Tcl_Seek testing flushing of buffered output} {
    set f [open test3 w]
    puts $f xyz\n123
    close $f
    set f [open test3 w+]
    puts $f xyzzy
    seek $f 2
    set x [gets $f]
    close $f
    list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
    set f [open test3 w]
    fconfigure $f -translation lf -eofchar {}
    puts $f xyz\n123
    close $f
    set f [open test3 a+]
    fconfigure $f -translation lf -eofchar {}
    puts $f xyzzy
    flush $f
    set x [tell $f]
    seek $f -4 cur
    set y [gets $f]
    close $f
    list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
    removeFile test1
    set f1 [open test1 w]
    set p [tell $f1]
    close $f1
    set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 0 end
    set c1 [tell $f1]
    close $f1
    set c1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open test1 r]
    seek $f1 10 start
    set c1 [tell $f1]
    seek $f1 10 current
    set c2 [tell $f1]
    close $f1
    list $c1 $c2
} {10 20}







|



|







|



|







|



|







|



|







|



|







|



|







|



|







|



|







|



|







|



|











|



|











|



|












|







|








|







|








|



|











|



|











|



|











|




|














|




|














|




|
















|




|












|




|












|




|








|




|








|




|








|




|








|




|








|




|











|



|












|



|












|



|












|



|













|



|















|



|















|



|















|



|















|



|















|



|















|



|















|



|















|











|



|














|



|














|



|













|



|














|




|














|



|














|




|













|




|












|




|
















|




|
















|




|
















|




|












|




|












|




|












|




|












|




|












|




|












|







|










|







|



















|





|







|








|




|






|











|





|






|




|







|


|








|



|














|



|







|



|







|



|








|



|








|



|










|



|









|











|


|












|






|





|






|


|











|





|





|





|






|





|






|





|









|







|




|







|




|







|




|







|




|








|




|









|




|

















|



|
















>
>
>

|



|









|


|







|



|













|






|




|







|




|







2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
    interp delete y
} ""

# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.

test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf
    set x [read $f]
    close $f
    set x
} "hello\rthere\rand\rhere\r"
test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x 
} "hello\rthere\rand\rhere\r"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set x [read $f]
    close $f
    set x
} "hello\nthere\nand\nhere\n"
test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf
    set x [read $f]
    close $f
    set x
} "hello\r\nthere\r\nand\r\nhere\r\n"
test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr
    set x [read $f]
    close $f
    set x
} "hello\n\nthere\n\nand\n\nhere\n\n"
test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    set c [read $f]
    set x [fconfigure $f -translation]
    close $f
    list $c $x
} {{hello
there
and
here
} auto}
test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    set c [read $f]
    set x [fconfigure $f -translation]
    close $f
    list $c $x
} {{hello
there
and
here
} auto}
test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    set c [read $f]
    set x [fconfigure $f -translation]
    close $f
    list $c $x
} {{hello
there
and
here
} auto}

test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto
    set c [read $f]
    close $f
    string length $c
} [expr 700*15+1]

test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set c [read $f]
    close $f
    string length $c
} [expr 700*15+1]

test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto
    set c [read $f]
    close $f
    set c
} {hello
there
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\nand\rhere\n\x1a
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set c [read $f]
    close $f
    set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -eofchar \x1a -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set c [read $f]
    close $f
    set c
} {hello
there
and
here
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar {}
    set l ""
    set x [gets $f]
    lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cghi\nqrs" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar {}
    set l ""
    set x [gets $f]
    lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {0 1 {} 1}
test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set c [format abc\ndef\n%cqrs\ntuv 26]
    puts $f $c
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set c [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $e
} {8 1}

# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.

test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 6 auto there 12 auto}
test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 6 auto there 12 auto}
test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 7 auto there 14 auto}
test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    close $f
    set l
} {hello 6 lf there 12 lf}
test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 cr 1 {} 21 cr 1}
test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {hello 6 cr 0 there 12 cr 0}
test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 lf 1 {} 21 lf 1}
test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {hello 7 crlf 0 there 14 crlf 0}
test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr
    set l ""
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {hello 6 cr 0 6 13 cr 0}
test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    puts $f hello\nthere\nand\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf
    set l ""
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    lappend l [string length [gets $f]]
    lappend l [tell $f]
    lappend l [fconfigure $f -translation]
    lappend l [eof $f]
    close $f
    set l
} {6 7 lf 0 6 14 lf 0}
test io-31.13 {binary mode is synonym of lf mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation binary
    set x [fconfigure $f -translation]
    close $f
    set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello\nthere\rand\r\nhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\rand\r\nhere\r
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\rand\r\nhere\n
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f hello\nthere\rand\r\nhere\r\n
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "hello\nthere\nand\rhere\n\%c" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -eofchar \x1a -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a
    fconfigure $f -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar {}
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar {}
    set s [format "abc\ndef\n%cqrs\ntuv" 26]
    puts $f $s
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l ""
    lappend l [gets $f]
    lappend l [gets $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {abc def 0 {} 1}
test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation crlf 
    set c ""
    while {[gets $f line] >= 0} {
	append c $line\n
    }
    close $f
    string length $c
} [expr 700*15+1]
test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set line "123456789ABCDE"	;# 14 char plus crlf
    puts -nonewline $f x	;# shift crlf across block boundary
    for {set i 0} {$i < 700} {incr i} {
	puts $f $line
    }
    close $f
    set f [open $path(test1) r]
    fconfigure $f -translation auto
    set c ""
    while {[gets $f line] >= 0} {
	append c $line\n
    }
    close $f
    string length $c
} [expr 700*15+1]


# Test Tcl_Read and buffering.

test io-32.1 {Tcl_Read, channel not readable} {
    list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test io-32.2 {Tcl_Read, zero byte count} {
    read stdin 0
} ""
test io-32.3 {Tcl_Read, negative byte count} {
    set f [open $path(longfile) r]
    set l [list [catch {read $f -1} msg] $msg]
    close $f
    set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-32.4 {Tcl_Read, positive byte count} {
    set f [open $path(longfile) r]
    set x [read $f 1024]
    set s [string length $x]
    unset x
    close $f
    set s
} 1024
test io-32.5 {Tcl_Read, multiple buffers} {
    set f [open $path(longfile) r]
    fconfigure $f -buffersize 100
    set x [read $f 1024]
    set s [string length $x]
    unset x
    close $f
    set s
} 1024
test io-32.6 {Tcl_Read, very large read} {
    set f1 [open $path(longfile) r]
    set z [read $f1 1000000]
    close $f1
    set l [string length $z]
    set x ok
    set z [file size $path(longfile)]
    if {$z != $l} {
	set x broken
    }
    set x
} ok
test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
    set f1 [open $path(longfile) r]
    fconfigure $f1 -blocking off
    set z [read $f1 20]
    close $f1
    set l [string length $z]
    set x ok
    if {$l != 20} {
	set x broken
    }
    set x
} ok
test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
    set f1 [open $path(longfile) r]
    fconfigure $f1 -blocking off
    set z [read $f1 1000000]
    close $f1
    set x ok
    set l [string length $z]
    set z [file size $path(longfile)]
    if {$z != $l} {
	set x broken
    }
    set x
} ok
test io-32.9 {Tcl_Read, read to end of file} {
    set f1 [open $path(longfile) r]
    set z [read $f1]
    close $f1
    set l [string length $z]
    set x ok
    set z [file size $path(longfile)]
    if {$z != $l} {
	set x broken
    }
    set x
} ok
test io-32.10 {Tcl_Read from a pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    flush $f1
    set x [read $f1]
    close $f1
    set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {puts [gets stdin]}
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    flush $f1
    set x ""
    lappend x [read $f1 6]
    puts $f1 hello
    flush $f1
    lappend x [read $f1]
    close $f1
    set x
} {{hello
} {hello
}}
test io-32.12 {Tcl_Read, -nonewline} {
    removeFile test1
    set f1 [open $path(test1) w]
    puts $f1 hello
    puts $f1 bye
    close $f1
    set f1 [open $path(test1) r]
    set c [read -nonewline $f1]
    close $f1
    set c
} {hello
bye}
test io-32.13 {Tcl_Read, -nonewline} {
    removeFile test1
    set f1 [open $path(test1) w]
    puts $f1 hello
    puts $f1 bye
    close $f1
    set f1 [open $path(test1) r]
    set c [read -nonewline $f1]
    close $f1
    list [string length $c] $c
} {9 {hello
bye}}
test io-32.14 {Tcl_Read, reading in small chunks} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [list [read $f 1] [read $f 2] [read $f]]
    close $f
    set x
} {T wo { lines: this one
and this one
}}
test io-32.15 {Tcl_Read, asking for more input than available} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [read $f 100]
    close $f
    set x
} {Two lines: this one
and this one
}
test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [read -nonewline $f]
    close $f
    set x
} {Two lines: this one
and this one}

# Test Tcl_Gets.

test io-33.1 {Tcl_Gets, reading what was written} {
    removeFile test1
    set f1 [open $path(test1) w]
    set y "first line"
    puts $f1 $y
    close $f1
    set f1 [open $path(test1) r]
    set x [gets $f1]
    set z ok
    if {"$x" != "$y"} {
	set z broken
    }
    close $f1
    set z
} ok
test io-33.2 {Tcl_Gets into variable} {
    set f1 [open $path(longfile) r]
    set c [gets $f1 x]
    set l [string length x]
    set z ok
    if {$l != $l} {
	set z broken
    }
    close $f1
    set z
} ok
test io-33.3 {Tcl_Gets from pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {puts [gets stdin]}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    flush $f1
    set x [gets $f1]
    close $f1
    set z ok
    if {"$x" != "hello"} {
	set z broken
    }
    set z
} ok
test io-33.4 {Tcl_Gets with long line} {
    removeFile test3
    set f [open $path(test3) w]
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    close $f
    set f [open $path(test3)]
    set x [gets $f]
    close $f
    set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.5 {Tcl_Gets with long line} {
    set f [open $path(test3)]
    set x [gets $f y]
    close $f
    list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.6 {Tcl_Gets and end of file} {
    removeFile test3
    set f [open $path(test3) w]
    puts -nonewline $f "Test1\nTest2"
    close $f
    set f [open $path(test3)]
    set x {}
    set y {}
    lappend x [gets $f y] $y
    set y {}
    lappend x [gets $f y] $y
    set y {}
    lappend x [gets $f y] $y
    close $f
    set x
} {5 Test1 5 Test2 -1 {}}
test io-33.7 {Tcl_Gets and bad variable} {
    set f [open $path(test3) w]
    puts $f "Line 1"
    puts $f "Line 2"
    close $f
    catch {unset x}
    set x 24
    set f [open $path(test3) r]
    set result [list [catch {gets $f x(0)} msg] $msg]
    close $f
    set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
    set f [open $path(test3) w]
    fconfigure $f -translation lf -eofchar {}
    set x ""
    for {set y 0} {$y < 99} {incr y} {set x "a$x"}
    for {set y 0} {$y < 100} {incr y} {puts $f $x}
    close $f
    set f [open $path(test3) r]
    fconfigure $f -translation lf
    for {set y 0} {$y < 100} {incr y} {gets $f}
    close $f
    set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
    set f [open $path(test3) w]
    fconfigure $f -translation lf -eofchar {}
    set x ""
    for {set y 0} {$y < 99} {incr y} {set x "a$x"}
    for {set y 0} {$y < 200} {incr y} {puts $f $x}
    close $f
    set f [open $path(test3) r]
    fconfigure $f -translation lf
    for {set y 0} {$y < 200} {incr y} {gets $f}
    close $f
    set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
    set f [open $path(test3) w]
    fconfigure $f -translation lf -eofchar {}
    set x ""
    for {set y 0} {$y < 99} {incr y} {set x "a$x"}
    for {set y 0} {$y < 300} {incr y} {puts $f $x}
    close $f
    set f [open $path(test3) r]
    fconfigure $f -translation lf
    for {set y 0} {$y < 300} {incr y} {gets $f}
    close $f
    set y
} 300

# Test Tcl_Seek and Tcl_Tell.

test io-34.1 {Tcl_Seek to current position at start of file} {
    set f1 [open $path(longfile) r]
    seek $f1 0 current
    set c [tell $f1]
    close $f1
    set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 10 start
    set c [tell $f1]
    close $f1
    set c
} 10
test io-34.3 {Tcl_Seek to end of file} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 0 end
    set c [tell $f1]
    close $f1
    set c
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 -10 end
    set c [tell $f1]
    close $f1
    set c
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 10 current
    seek $f1 10 current
    set c [tell $f1]
    close $f1
    set c
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 -10 end
    set c [tell $f1]
    set r [read $f1]
    close $f1
    list $c $r
} {44 {rstuvwxyz
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 -10 end
    set c1 [tell $f1]
    set r1 [read $f1 5]
    seek $f1 0 current
    set c2 [tell $f1]
    close $f1
    list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} {stdio} {
    set f1 [open "|[list [interpreter]]" r+]
    set x [list [catch {seek $f1 0 current} msg] $msg]
    close $f1
    regsub {".*":} $x {"":} x
    string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
    removeFile test3
    set f [open $path(test3) w]
    fconfigure $f -eofchar {}
    puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    close $f
    set f [open $path(test3) RDWR]
    set x [read $f 1]
    seek $f 3
    lappend x [read $f 1]
    seek $f 0 start
    lappend x [read $f 1]
    seek $f 10 current
    lappend x [read $f 1]
    seek $f -2 end
    lappend x [read $f 1]
    seek $f 50 end
    lappend x [read $f 1]
    seek $f 1
    lappend x [read $f 1]
    close $f
    set x
} {a d a l Y {} b}

set path(test3) [makeFile {} test3]

test io-34.10 {Tcl_Seek testing flushing of buffered input} {
    set f [open $path(test3) w]
    fconfigure $f -translation lf
    puts $f xyz\n123
    close $f
    set f [open $path(test3) r+]
    fconfigure $f -translation lf
    set x [gets $f]
    seek $f 0 current
    puts $f 456
    close $f
    list $x [viewFile test3]
} "xyz {xyz
456}"
test io-34.11 {Tcl_Seek testing flushing of buffered output} {
    set f [open $path(test3) w]
    puts $f xyz\n123
    close $f
    set f [open $path(test3) w+]
    puts $f xyzzy
    seek $f 2
    set x [gets $f]
    close $f
    list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
    set f [open $path(test3) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f xyz\n123
    close $f
    set f [open $path(test3) a+]
    fconfigure $f -translation lf -eofchar {}
    puts $f xyzzy
    flush $f
    set x [tell $f]
    seek $f -4 cur
    set y [gets $f]
    close $f
    list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
    removeFile test1
    set f1 [open $path(test1) w]
    set p [tell $f1]
    close $f1
    set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 0 end
    set c1 [tell $f1]
    close $f1
    set c1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {}
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    puts $f1 "abcdefghijklmnopqrstuvwxyz"
    close $f1
    set f1 [open $path(test1) r]
    seek $f1 10 start
    set c1 [tell $f1]
    seek $f1 10 current
    set c2 [tell $f1]
    close $f1
    list $c1 $c2
} {10 20}
4284
4285
4286
4287
4288
4289
4290
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
    set c [tell $f1]
    gets $f1
    close $f1
    set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
    removeFile test2
    set f [open test2 w]
    fconfigure $f -translation lf -eofchar {}
    puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
    close $f
    set f [open test2]
    fconfigure $f -translation lf
    set x [tell $f]
    read $f 3
    lappend x [tell $f]
    seek $f 2
    lappend x [tell $f]
    seek $f 10 current
    lappend x [tell $f]
    seek $f 0 end
    lappend x [tell $f]
    close $f
    set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
    set f [open test3 w]
    fconfigure $f -translation lf -eofchar {}
    puts $f "abcdefghijklmnopqrstuvwxyz"
    puts $f "abcdefghijklmnopqrstuvwxyz"
    close $f
    set f [open test3 a]
    set c [tell $f]
    close $f
    set c
} 54
test io-34.20 {Tcl_Tell combined with writing} {
    set f [open test3 w]
    set l ""
    seek $f 29 start
    lappend l [tell $f]
    puts -nonewline $f a
    seek $f 39 start
    lappend l [tell $f]
    puts -nonewline $f a
    lappend l [tell $f]
    seek $f 407 end
    lappend l [tell $f]
    close $f
    set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
    removeFile test3
    set f [open test3 w]
    fconfigure $f -encoding binary
    set l ""
    lappend l [tell $f]
    puts -nonewline $f abcdef
    lappend l [tell $f]
    flush $f
    lappend l [tell $f]
    # 4GB offset!
    seek $f 0x100000000
    lappend l [tell $f]
    puts -nonewline $f abcdef
    lappend l [tell $f]
    close $f
    lappend l [file size $f]
    # truncate...
    close [open test3 w]
    lappend l [file size $f]
    set l
} {0 6 6 4294967296 4294967302 4294967302 0}

# Test Tcl_Eof

test io-35.1 {Tcl_Eof} {
    removeFile test1
    set f [open test1 w]
    puts $f hello
    puts $f hello
    close $f
    set f [open test1]
    set x [eof $f]
    lappend x [eof $f]
    gets $f
    lappend x [eof $f]
    gets $f
    lappend x [eof $f]
    gets $f
    lappend x [eof $f]
    lappend x [eof $f]
    close $f
    set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {gets stdin}
    puts $f1 {puts hello}
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    puts $f1 hello
    set x [eof $f1]
    flush $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    close $f1
    set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {gets stdin}
    puts $f1 {puts hello}
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    puts $f1 hello
    set x [eof $f1]
    flush $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    close $f1
    set x
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    fconfigure $f -blocking off
    set l ""
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} {
    removeFile pipe
    set f [open pipe w]
    puts $f {
	exit
    }
    close $f
    set f [open "|[list [interpreter] pipe]" r]
    set l ""
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size test1]
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size test1]
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size test1]
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size test1]
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size test1]
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {11 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size test1]
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {11 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size test1]
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size test1]
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size test1]
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size test1]
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size test1]
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size test1]
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {21 8 1}








|



|














|




|





|















|















|








|



|














|



|













|



|

















|

|









|




|








|



|
|








|



|
|








|



|
|








|



|
|








|



|
|








|



|
|








|




|
|








|




|
|








|




|
|








|




|
|








|




|
|








|




|
|







4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
    set c [tell $f1]
    gets $f1
    close $f1
    set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
    removeFile test2
    set f [open $path(test2) w]
    fconfigure $f -translation lf -eofchar {}
    puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
    close $f
    set f [open $path(test2)]
    fconfigure $f -translation lf
    set x [tell $f]
    read $f 3
    lappend x [tell $f]
    seek $f 2
    lappend x [tell $f]
    seek $f 10 current
    lappend x [tell $f]
    seek $f 0 end
    lappend x [tell $f]
    close $f
    set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
    set f [open $path(test3) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f "abcdefghijklmnopqrstuvwxyz"
    puts $f "abcdefghijklmnopqrstuvwxyz"
    close $f
    set f [open $path(test3) a]
    set c [tell $f]
    close $f
    set c
} 54
test io-34.20 {Tcl_Tell combined with writing} {
    set f [open $path(test3) w]
    set l ""
    seek $f 29 start
    lappend l [tell $f]
    puts -nonewline $f a
    seek $f 39 start
    lappend l [tell $f]
    puts -nonewline $f a
    lappend l [tell $f]
    seek $f 407 end
    lappend l [tell $f]
    close $f
    set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
    removeFile test3
    set f [open $path(test3) w]
    fconfigure $f -encoding binary
    set l ""
    lappend l [tell $f]
    puts -nonewline $f abcdef
    lappend l [tell $f]
    flush $f
    lappend l [tell $f]
    # 4GB offset!
    seek $f 0x100000000
    lappend l [tell $f]
    puts -nonewline $f abcdef
    lappend l [tell $f]
    close $f
    lappend l [file size $f]
    # truncate...
    close [open $path(test3) w]
    lappend l [file size $f]
    set l
} {0 6 6 4294967296 4294967302 4294967302 0}

# Test Tcl_Eof

test io-35.1 {Tcl_Eof} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f hello
    puts $f hello
    close $f
    set f [open $path(test1)]
    set x [eof $f]
    lappend x [eof $f]
    gets $f
    lappend x [eof $f]
    gets $f
    lappend x [eof $f]
    gets $f
    lappend x [eof $f]
    lappend x [eof $f]
    close $f
    set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {gets stdin}
    puts $f1 {puts hello}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    set x [eof $f1]
    flush $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    close $f1
    set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {gets stdin}
    puts $f1 {puts hello}
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    puts $f1 hello
    set x [eof $f1]
    flush $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    gets $f1
    lappend x [eof $f1]
    close $f1
    set x
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    fconfigure $f -blocking off
    set l ""
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} {
    removeFile pipe
    set f [open $path(pipe) w]
    puts $f {
	exit
    }
    close $f
    set f [open "|[list [interpreter] $path(pipe)]" r]
    set l ""
    lappend l [gets $f]
    lappend l [eof $f]
    close $f
    set l
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {9 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {11 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar \x1a
    puts $f abc\ndef
    close $f
    set s [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $s $l $e
} {11 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf -eofchar {}
    set i [format abc\ndef\n%cqrs\nuvw 26]
    puts $f $i
    close $f
    set c [file size $path(test1)]
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    set l [string length [read $f]]
    set e [eof $f]
    close $f
    list $c $l $e
} {21 8 1}

4650
4651
4652
4653
4654
4655
4656
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
    lappend x [fblocked $f1]
    lappend x [eof $f1]
    close $f1
    set x
} {hello_from_pipe 0 {} 0 1}
test io-36.3 {Tcl_InputBlocked vs files, short read} {
    removeFile test1
    set f [open test1 w]
    puts $f abcdefghijklmnop
    close $f
    set f [open test1 r]
    set l ""
    lappend l [fblocked $f]
    lappend l [read $f 3]
    lappend l [fblocked $f]
    lappend l [read -nonewline $f]
    lappend l [fblocked $f]
    lappend l [eof $f]
    close $f
    set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {
    proc in {f} {
        variable l
        variable x
	lappend l [read $f 3]
	if {[eof $f]} {lappend l eof; close $f; set x done}
    }
    removeFile test1
    set f [open test1 w]
    puts $f abcdefghijklmnop
    close $f
    set f [open test1 r]
    set l ""
    fileevent $f readable [namespace code [list in $f]]
    variable x
    vwait [namespace which -variable x]
    set l
} {abc def ghi jkl mno {p
} eof}
test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
    removeFile test1
    set f [open test1 w]
    puts $f abcdefghijklmnop
    close $f
    set f [open test1 r]
    fconfigure $f -blocking off
    set l ""
    lappend l [fblocked $f]
    lappend l [read $f 3]
    lappend l [fblocked $f]
    lappend l [read -nonewline $f]
    lappend l [fblocked $f]
    lappend l [eof $f]
    close $f
    set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} {
    proc in {f} {
        variable l
        variable x
	lappend l [read $f 3]
	if {[eof $f]} {lappend l eof; close $f; set x done}
    }
    removeFile test1
    set f [open test1 w]
    puts $f abcdefghijklmnop
    close $f
    set f [open test1 r]
    fconfigure $f -blocking off
    set l ""
    fileevent $f readable [namespace code [list in $f]]
    variable x
    vwait [namespace which -variable x]
    set l
} {abc def ghi jkl mno {p
} eof}

# Test Tcl_InputBuffered

test io-37.1 {Tcl_InputBuffered} {testchannel} {
    set f [open longfile r]
    fconfigure $f -buffersize 4096
    read $f 3
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {4093 3}
test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
    set f [open longfile r]
    fconfigure $f -buffersize 4096
    read $f 3
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    seek $f 0 current
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {4093 3 0 3}

# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize

test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
    set f [open longfile r]
    set s [fconfigure $f -buffersize]
    close $f
    set s
} 4096
test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
    set f [open longfile r]
    set l ""
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 10000
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 1
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize -1







|


|


















|


|









|


|



















|


|












|









|















|





|







4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
    lappend x [fblocked $f1]
    lappend x [eof $f1]
    close $f1
    set x
} {hello_from_pipe 0 {} 0 1}
test io-36.3 {Tcl_InputBlocked vs files, short read} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [fblocked $f]
    lappend l [read $f 3]
    lappend l [fblocked $f]
    lappend l [read -nonewline $f]
    lappend l [fblocked $f]
    lappend l [eof $f]
    close $f
    set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {
    proc in {f} {
        variable l
        variable x
	lappend l [read $f 3]
	if {[eof $f]} {lappend l eof; close $f; set x done}
    }
    removeFile test1
    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f
    set f [open $path(test1) r]
    set l ""
    fileevent $f readable [namespace code [list in $f]]
    variable x
    vwait [namespace which -variable x]
    set l
} {abc def ghi jkl mno {p
} eof}
test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f
    set f [open $path(test1) r]
    fconfigure $f -blocking off
    set l ""
    lappend l [fblocked $f]
    lappend l [read $f 3]
    lappend l [fblocked $f]
    lappend l [read -nonewline $f]
    lappend l [fblocked $f]
    lappend l [eof $f]
    close $f
    set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} {
    proc in {f} {
        variable l
        variable x
	lappend l [read $f 3]
	if {[eof $f]} {lappend l eof; close $f; set x done}
    }
    removeFile test1
    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f
    set f [open $path(test1) r]
    fconfigure $f -blocking off
    set l ""
    fileevent $f readable [namespace code [list in $f]]
    variable x
    vwait [namespace which -variable x]
    set l
} {abc def ghi jkl mno {p
} eof}

# Test Tcl_InputBuffered

test io-37.1 {Tcl_InputBuffered} {testchannel} {
    set f [open $path(longfile) r]
    fconfigure $f -buffersize 4096
    read $f 3
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {4093 3}
test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
    set f [open $path(longfile) r]
    fconfigure $f -buffersize 4096
    read $f 3
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    seek $f 0 current
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {4093 3 0 3}

# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize

test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
    set f [open $path(longfile) r]
    set s [fconfigure $f -buffersize]
    close $f
    set s
} 4096
test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
    set f [open $path(longfile) r]
    set l ""
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 10000
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize 1
    lappend l [fconfigure $f -buffersize]
    fconfigure $f -buffersize -1
4790
4791
4792
4793
4794
4795
4796
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
    close $chan
} {}

# Test Tcl_SetChannelOption, Tcl_GetChannelOption

test io-39.1 {Tcl_GetChannelOption} {
    removeFile test1
    set f1 [open test1 w]
    set x [fconfigure $f1 -blocking]
    close $f1
    set x
} 1
#
# Test 17.2 was removed.
#
test io-39.2 {Tcl_GetChannelOption} {
    removeFile test1
    set f1 [open test1 w]
    set x [fconfigure $f1 -buffering]
    close $f1
    set x
} full
test io-39.3 {Tcl_GetChannelOption} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -buffering line
    set x [fconfigure $f1 -buffering]
    close $f1
    set x
} line
test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
    removeFile test1
    set f1 [open test1 w]
    set l ""
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering line
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering none
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering line
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering full
    lappend l [fconfigure $f1 -buffering]
    close $f1
    set l
} {full line none line full}
test io-39.5 {Tcl_GetChannelOption, invariance} {
    removeFile test1
    set f1 [open test1 w]
    set l ""
    lappend l [fconfigure $f1 -buffering]
    lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
    lappend l [fconfigure $f1 -buffering]
    close $f1
    set l
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -buffering line
    puts $f1 hello
    puts $f1 bye
    set x [file size test1]
    close $f1
    set x
} 10
test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf
    puts $f1 hello
    puts $f1 bye
    set x ""
    fconfigure $f1 -buffering line
    lappend x [file size test1]
    puts $f1 really_bye
    lappend x [file size test1]
    close $f1
    set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
    removeFile test1
    set f1 [open test1 w]
    set l ""
    fconfigure $f1 -translation lf -buffering none -eofchar {}
    puts -nonewline $f1 hello
    lappend l [file size test1]
    puts -nonewline $f1 hello
    lappend l [file size test1]
    fconfigure $f1 -buffering full
    puts -nonewline $f1 hello
    lappend l [file size test1]
    fconfigure $f1 -buffering none
    lappend l [file size test1]
    puts -nonewline $f1 hello
    lappend l [file size test1]
    close $f1
    lappend l [file size test1]
    set l
} {5 10 10 10 20 20}
test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
    removeFile test1
    set f1 [open test1 w]
    close $f1
    set f1 [open test1 r]
    set x ""
    lappend x [fconfigure $f1 -blocking]
    fconfigure $f1 -blocking off
    lappend x [fconfigure $f1 -blocking]
    lappend x [gets $f1]
    lappend x [read $f1 1000]
    lappend x [fblocked $f1]
    lappend x [eof $f1]
    close $f1
    set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio} {
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	gets stdin
	after 100
	puts hi
	gets stdin
    }
    close $f1
    set x ""
    set f1 [open "|[list [interpreter] pipe]" r+]
    fconfigure $f1 -blocking off -buffering line
    lappend x [fconfigure $f1 -blocking]
    lappend x [gets $f1]
    lappend x [fblocked $f1]
    fconfigure $f1 -blocking on
    puts $f1 hello
    fconfigure $f1 -blocking off







|









|






|







|















|









|



|





|





|

|





|



|

|


|

|

|

|




|

|













|








|







4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
    close $chan
} {}

# Test Tcl_SetChannelOption, Tcl_GetChannelOption

test io-39.1 {Tcl_GetChannelOption} {
    removeFile test1
    set f1 [open $path(test1) w]
    set x [fconfigure $f1 -blocking]
    close $f1
    set x
} 1
#
# Test 17.2 was removed.
#
test io-39.2 {Tcl_GetChannelOption} {
    removeFile test1
    set f1 [open $path(test1) w]
    set x [fconfigure $f1 -buffering]
    close $f1
    set x
} full
test io-39.3 {Tcl_GetChannelOption} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -buffering line
    set x [fconfigure $f1 -buffering]
    close $f1
    set x
} line
test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
    removeFile test1
    set f1 [open $path(test1) w]
    set l ""
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering line
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering none
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering line
    lappend l [fconfigure $f1 -buffering]
    fconfigure $f1 -buffering full
    lappend l [fconfigure $f1 -buffering]
    close $f1
    set l
} {full line none line full}
test io-39.5 {Tcl_GetChannelOption, invariance} {
    removeFile test1
    set f1 [open $path(test1) w]
    set l ""
    lappend l [fconfigure $f1 -buffering]
    lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
    lappend l [fconfigure $f1 -buffering]
    close $f1
    set l
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -buffering line
    puts $f1 hello
    puts $f1 bye
    set x [file size $path(test1)]
    close $f1
    set x
} 10
test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf
    puts $f1 hello
    puts $f1 bye
    set x ""
    fconfigure $f1 -buffering line
    lappend x [file size $path(test1)]
    puts $f1 really_bye
    lappend x [file size $path(test1)]
    close $f1
    set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
    removeFile test1
    set f1 [open $path(test1) w]
    set l ""
    fconfigure $f1 -translation lf -buffering none -eofchar {}
    puts -nonewline $f1 hello
    lappend l [file size $path(test1)]
    puts -nonewline $f1 hello
    lappend l [file size $path(test1)]
    fconfigure $f1 -buffering full
    puts -nonewline $f1 hello
    lappend l [file size $path(test1)]
    fconfigure $f1 -buffering none
    lappend l [file size $path(test1)]
    puts -nonewline $f1 hello
    lappend l [file size $path(test1)]
    close $f1
    lappend l [file size $path(test1)]
    set l
} {5 10 10 10 20 20}
test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
    removeFile test1
    set f1 [open $path(test1) w]
    close $f1
    set f1 [open $path(test1) r]
    set x ""
    lappend x [fconfigure $f1 -blocking]
    fconfigure $f1 -blocking off
    lappend x [fconfigure $f1 -blocking]
    lappend x [gets $f1]
    lappend x [read $f1 1000]
    lappend x [fblocked $f1]
    lappend x [eof $f1]
    close $f1
    set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio} {
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {
	gets stdin
	after 100
	puts hi
	gets stdin
    }
    close $f1
    set x ""
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f1 -blocking off -buffering line
    lappend x [fconfigure $f1 -blocking]
    lappend x [gets $f1]
    lappend x [fblocked $f1]
    fconfigure $f1 -blocking on
    puts $f1 hello
    fconfigure $f1 -blocking off
4937
4938
4939
4940
4941
4942
4943
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
    lappend x [gets $f1]
    lappend x [eof $f1]
    close $f1
    set x
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -buffersize -10
    set x [fconfigure $f -buffersize]
    close $f
    set x
} 4096
test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -buffersize 10000000
    set x [fconfigure $f -buffersize]
    close $f
    set x
} 4096
test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -buffersize 40000
    set x [fconfigure $f -buffersize]
    close $f
    set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -encoding {} 
    puts -nonewline $f \xe7\x89\xa6
    close $f
    set f [open test1 r]
    fconfigure $f -encoding utf-8
    set x [read $f]
    close $f
    set x
} \u7266
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -encoding binary
    puts -nonewline $f \xe7\x89\xa6
    close $f
    set f [open test1 r]
    fconfigure $f -encoding utf-8
    set x [read $f]
    close $f
    set x
} \u7266
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
    removeFile test1
    set f [open test1 w]
    set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
    close $f
    set result
} {1 {unknown encoding "foobar"}}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio} {
    set f [open "|[list [interpreter] cat]" r+]
    fconfigure $f -encoding binary
    puts -nonewline $f "\xe7"
    flush $f
    fconfigure $f -encoding utf-8 -blocking 0
    variable x {}
    fileevent $f readable [namespace code { lappend x [read $f] }]
    vwait [namespace which -variable x]







|







|







|







|



|







|



|







|





|







4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
    lappend x [gets $f1]
    lappend x [eof $f1]
    close $f1
    set x
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -buffersize -10
    set x [fconfigure $f -buffersize]
    close $f
    set x
} 4096
test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -buffersize 10000000
    set x [fconfigure $f -buffersize]
    close $f
    set x
} 4096
test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -buffersize 40000
    set x [fconfigure $f -buffersize]
    close $f
    set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -encoding {} 
    puts -nonewline $f \xe7\x89\xa6
    close $f
    set f [open $path(test1) r]
    fconfigure $f -encoding utf-8
    set x [read $f]
    close $f
    set x
} \u7266
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -encoding binary
    puts -nonewline $f \xe7\x89\xa6
    close $f
    set f [open $path(test1) r]
    fconfigure $f -encoding utf-8
    set x [read $f]
    close $f
    set x
} \u7266
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
    removeFile test1
    set f [open $path(test1) w]
    set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
    close $f
    set result
} {1 {unknown encoding "foobar"}}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio} {
    set f [open "|[list [interpreter] $path(cat)]" r+]
    fconfigure $f -encoding binary
    puts -nonewline $f "\xe7"
    flush $f
    fconfigure $f -encoding utf-8 -blocking 0
    variable x {}
    fileevent $f readable [namespace code { lappend x [read $f] }]
    vwait [namespace which -variable x]
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
    close $s1
    close $s2
    set modes
} {auto crlf}

test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
    removeFile test1
    set f1 [open test1 w+]
    set l ""
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar {ON GO}
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar D
    lappend l [fconfigure $f1 -eofchar]
    close $f1
    set l
} {{{} {}} {O G} {D D}}

test io-39.22a {Tcl_SetChannelOption, invariance} {
    removeFile test1
    set f1 [open test1 w+]
    set l [list]
    fconfigure $f1 -eofchar {ON GO}
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar D
    lappend l [fconfigure $f1 -eofchar]
    lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
    close $f1







|












|







5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
    close $s1
    close $s2
    set modes
} {auto crlf}

test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
    removeFile test1
    set f1 [open $path(test1) w+]
    set l ""
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar {ON GO}
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar D
    lappend l [fconfigure $f1 -eofchar]
    close $f1
    set l
} {{{} {}} {O G} {D D}}

test io-39.22a {Tcl_SetChannelOption, invariance} {
    removeFile test1
    set f1 [open $path(test1) w+]
    set l [list]
    fconfigure $f1 -eofchar {ON GO}
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar D
    lappend l [fconfigure $f1 -eofchar]
    lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
    close $f1
5113
5114
5115
5116
5117
5118
5119
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
    lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
    close $sock
    set l
} {{{}} auto}

test io-40.1 {POSIX open access modes: RDWR} {
    removeFile test3
    set f [open test3 w]
    puts $f xyzzy
    close $f
    set f [open test3 RDWR]
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [gets $f]
    close $f
    set f [open test3 r]
    lappend x [gets $f]
    close $f
    set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
    removeFile test3
    set f [open test3 {WRONLY CREAT} 0600]
    file stat test3 stats
    set x [format "0%o" [expr $stats(mode)&0777]]
    puts $f "line 1"
    close $f
    set f [open test3 r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
catch {testConstraint umask2 [expr {[exec umask] == 2}]}

test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
    # This test only works if your umask is 2, like ouster's.
    removeFile test3
    set f [open test3 {WRONLY CREAT}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664
test io-40.4 {POSIX open access modes: CREAT} {
    removeFile test3
    set f [open test3 w]
    fconfigure $f -eofchar {}
    puts $f xyzzy
    close $f
    set f [open test3 {WRONLY CREAT}]
    fconfigure $f -eofchar {}
    puts -nonewline $f "ab"
    close $f
    set f [open test3 r]
    set x [gets $f]
    close $f
    set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
    removeFile test3
    set f [open test3 w]
    fconfigure $f -translation lf -eofchar {}
    puts $f xyzzy
    close $f
    set f [open test3 {WRONLY APPEND}]
    fconfigure $f -translation lf
    puts $f "new line"
    seek $f 0
    puts $f "abc"
    close $f
    set f [open test3 r]
    fconfigure $f -translation lf
    set x ""
    seek $f 6 current
    lappend x [gets $f]
    lappend x [gets $f]
    close $f
    set x
} {{new line} abc}
test io-40.6 {POSIX open access modes: EXCL} {
    removeFile test3
    set f [open test3 w]
    puts $f xyzzy
    close $f
    set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg]
    regsub " already " $msg " " msg
    regsub [file join {} test3] $msg "test3" msg
    string tolower $msg
} {1 {couldn't open "test3": file exists}}
test io-40.7 {POSIX open access modes: EXCL} {
    removeFile test3
    set f [open test3 {WRONLY CREAT EXCL}]
    fconfigure $f -eofchar {}
    puts $f "A test line"
    close $f
    viewFile test3
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
    removeFile test3
    set f [open test3 w]
    puts $f xyzzy
    close $f
    set f [open test3 {WRONLY TRUNC}]
    puts $f abc
    close $f
    set f [open test3 r]
    set x [gets $f]
    close $f
    set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
    removeFile test3
    set f [open test3 {WRONLY NONBLOCK CREAT}]
    puts $f "NONBLOCK test"
    close $f
    set f [open test3 r]
    set x [gets $f]
    close $f
    set x
} {NONBLOCK test}
test io-40.10 {POSIX open access modes: RDONLY} {
    set f [open test1 w]
    puts $f "two lines: this one"
    puts $f "and this"
    close $f
    set f [open test1 RDONLY]
    set x [list [gets $f] [catch {puts $f Test} msg] $msg]
    close $f
    string compare [string tolower $x] \
	[list {two lines: this one} 1 \
		[format "channel \"%s\" wasn't opened for writing" $f]]
} 0
test io-40.11 {POSIX open access modes: RDONLY} {
    removeFile test3
    set msg [list [catch {open test3 RDONLY} msg] $msg]
    regsub [file join {} test3] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.12 {POSIX open access modes: WRONLY} {
    removeFile test3
    set msg [list [catch {open test3 WRONLY} msg] $msg]
    regsub [file join {} test3] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.13 {POSIX open access modes: WRONLY} {
    makeFile xyzzy test3
    set f [open test3 WRONLY]
    fconfigure $f -eofchar {}
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [list [catch {gets $f} msg] $msg]
    close $f
    lappend x [viewFile test3]
    string compare [string tolower $x] \
	[list 1 "channel \"$f\" wasn't opened for reading" abzzy]
} 0
test io-40.14 {POSIX open access modes: RDWR} {
    removeFile test3
    set msg [list [catch {open test3 RDWR} msg] $msg]
    regsub [file join {} test3] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.15 {POSIX open access modes: RDWR} {
    makeFile xyzzy test3
    set f [open test3 RDWR]
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [gets $f]
    close $f
    lappend x [viewFile test3]
} {zzy abzzy}
if {![file exists ~/_test_] && [file writable ~]} {







|


|




|






|
|



|












|






|



|



|






|



|





|










|


|

|




|







|


|


|






|


|





|



|








|
|




|
|




|











|
|




|







5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
    lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
    close $sock
    set l
} {{{}} auto}

test io-40.1 {POSIX open access modes: RDWR} {
    removeFile test3
    set f [open $path(test3) w]
    puts $f xyzzy
    close $f
    set f [open $path(test3) RDWR]
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [gets $f]
    close $f
    set f [open $path(test3) r]
    lappend x [gets $f]
    close $f
    set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
    removeFile test3
    set f [open $path(test3) {WRONLY CREAT} 0600]
    file stat $path(test3) stats
    set x [format "0%o" [expr $stats(mode)&0777]]
    puts $f "line 1"
    close $f
    set f [open $path(test3) r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
catch {testConstraint umask2 [expr {[exec umask] == 2}]}

test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
    # This test only works if your umask is 2, like ouster's.
    removeFile test3
    set f [open $path(test3) {WRONLY CREAT}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664
test io-40.4 {POSIX open access modes: CREAT} {
    removeFile test3
    set f [open $path(test3) w]
    fconfigure $f -eofchar {}
    puts $f xyzzy
    close $f
    set f [open $path(test3) {WRONLY CREAT}]
    fconfigure $f -eofchar {}
    puts -nonewline $f "ab"
    close $f
    set f [open $path(test3) r]
    set x [gets $f]
    close $f
    set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
    removeFile test3
    set f [open $path(test3) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f xyzzy
    close $f
    set f [open $path(test3) {WRONLY APPEND}]
    fconfigure $f -translation lf
    puts $f "new line"
    seek $f 0
    puts $f "abc"
    close $f
    set f [open $path(test3) r]
    fconfigure $f -translation lf
    set x ""
    seek $f 6 current
    lappend x [gets $f]
    lappend x [gets $f]
    close $f
    set x
} {{new line} abc}
test io-40.6 {POSIX open access modes: EXCL} {
    removeFile test3
    set f [open $path(test3) w]
    puts $f xyzzy
    close $f
    set msg [list [catch {open $path(test3) {WRONLY CREAT EXCL}} msg] $msg]
    regsub " already " $msg " " msg
    regsub [file join {} $path(test3)] $msg "test3" msg
    string tolower $msg
} {1 {couldn't open "test3": file exists}}
test io-40.7 {POSIX open access modes: EXCL} {
    removeFile test3
    set f [open $path(test3) {WRONLY CREAT EXCL}]
    fconfigure $f -eofchar {}
    puts $f "A test line"
    close $f
    viewFile test3
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
    removeFile test3
    set f [open $path(test3) w]
    puts $f xyzzy
    close $f
    set f [open $path(test3) {WRONLY TRUNC}]
    puts $f abc
    close $f
    set f [open $path(test3) r]
    set x [gets $f]
    close $f
    set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
    removeFile test3
    set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
    puts $f "NONBLOCK test"
    close $f
    set f [open $path(test3) r]
    set x [gets $f]
    close $f
    set x
} {NONBLOCK test}
test io-40.10 {POSIX open access modes: RDONLY} {
    set f [open $path(test1) w]
    puts $f "two lines: this one"
    puts $f "and this"
    close $f
    set f [open $path(test1) RDONLY]
    set x [list [gets $f] [catch {puts $f Test} msg] $msg]
    close $f
    string compare [string tolower $x] \
	[list {two lines: this one} 1 \
		[format "channel \"%s\" wasn't opened for writing" $f]]
} 0
test io-40.11 {POSIX open access modes: RDONLY} {
    removeFile test3
    set msg [list [catch {open $path(test3) RDONLY} msg] $msg]
    regsub [file join {} $path(test3)] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.12 {POSIX open access modes: WRONLY} {
    removeFile test3
    set msg [list [catch {open $path(test3) WRONLY} msg] $msg]
    regsub [file join {} $path(test3)] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.13 {POSIX open access modes: WRONLY} {
    makeFile xyzzy test3
    set f [open $path(test3) WRONLY]
    fconfigure $f -eofchar {}
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [list [catch {gets $f} msg] $msg]
    close $f
    lappend x [viewFile test3]
    string compare [string tolower $x] \
	[list 1 "channel \"$f\" wasn't opened for reading" abzzy]
} 0
test io-40.14 {POSIX open access modes: RDWR} {
    removeFile test3
    set msg [list [catch {open $path(test3) RDWR} msg] $msg]
    regsub [file join {} $path(test3)] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.15 {POSIX open access modes: RDWR} {
    makeFile xyzzy test3
    set f [open $path(test3) RDWR]
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [gets $f]
    close $f
    lappend x [viewFile test3]
} {zzy abzzy}
if {![file exists ~/_test_] && [file writable ~]} {
5317
5318
5319
5320
5321
5322
5323

5324
5325
5326
5327
5328
5329
5330
5331
    list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}

#
# Test fileevent on a file
#


set f [open foo w+]

test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {
    list [fileevent $f readable] [fileevent $f writable]
} {{} {}}
test io-42.2 {Tcl_FileeventCmd: replacing} {
    set result {}
    fileevent $f r "first script"







>
|







5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
    list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}

#
# Test fileevent on a file
#

set path(foo) [makeFile {} foo]
set f [open $path(foo) w+]

test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {
    list [fileevent $f readable] [fileevent $f writable]
} {{} {}}
test io-42.2 {Tcl_FileeventCmd: replacing} {
    set result {}
    fileevent $f r "first script"
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
    fileevent $f2 writable {error bad-write}
    variable x initial
    vwait [namespace which -variable x]
    rename ::bgerror {}
    list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
    set f4 [open "|[list [interpreter] cat << foo]" r]
    fileevent $f4 readable [namespace code {
	if {[gets $f4 line] < 0} {
	    lappend x eof
	    fileevent $f4 readable {}
	} else {
	    lappend x $line
	}







|







5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
    fileevent $f2 writable {error bad-write}
    variable x initial
    vwait [namespace which -variable x]
    rename ::bgerror {}
    list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
    set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
    fileevent $f4 readable [namespace code {
	if {[gets $f4 line] < 0} {
	    lappend x eof
	    fileevent $f4 readable {}
	} else {
	    lappend x $line
	}
5443
5444
5445
5446
5447
5448
5449
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
catch {close $f2}
catch {close $f3}


close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    fileevent $f readable [namespace code {
	lappend x "binding triggered: \"[gets $f]\""
	fileevent $f readable {}
    }]
    close $f
    set x initial
    after 100 [namespace code { set y done }]
    variable y
    vwait [namespace which -variable y]
    set x
} {initial}
test io-45.2 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    set f2 [open foo r]
    fileevent $f readable [namespace code {
	    lappend x "f triggered: \"[gets $f]\""
	    fileevent $f readable {}
	}]
    fileevent $f2 readable [namespace code {
	lappend x "f2 triggered: \"[gets $f2]\""
	fileevent $f2 readable {}
    }]
    close $f
    variable x initial
    vwait [namespace which -variable x]
    close $f2
    set x
} {initial {f2 triggered: "foo bar"}}
test io-45.3 {DeleteFileEvent, cleanup on close} {
    set f [open foo r]
    set f2 [open foo r]
    set f3 [open foo r]
    fileevent $f readable {f script}
    fileevent $f2 readable {f2 script}
    fileevent $f3 readable {f3 script}
    set x {}
    close $f2
    lappend x [catch {fileevent $f readable} msg] $msg \
	    [catch {fileevent $f2 readable}] \







|












|
|















|
|
|







5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
catch {close $f2}
catch {close $f3}


close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
    set f [open $path(foo) r]
    fileevent $f readable [namespace code {
	lappend x "binding triggered: \"[gets $f]\""
	fileevent $f readable {}
    }]
    close $f
    set x initial
    after 100 [namespace code { set y done }]
    variable y
    vwait [namespace which -variable y]
    set x
} {initial}
test io-45.2 {DeleteFileEvent, cleanup on close} {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    fileevent $f readable [namespace code {
	    lappend x "f triggered: \"[gets $f]\""
	    fileevent $f readable {}
	}]
    fileevent $f2 readable [namespace code {
	lappend x "f2 triggered: \"[gets $f2]\""
	fileevent $f2 readable {}
    }]
    close $f
    variable x initial
    vwait [namespace which -variable x]
    close $f2
    set x
} {initial {f2 triggered: "foo bar"}}
test io-45.3 {DeleteFileEvent, cleanup on close} {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    fileevent $f readable {f script}
    fileevent $f2 readable {f2 script}
    fileevent $f3 readable {f3 script}
    set x {}
    close $f2
    lappend x [catch {fileevent $f readable} msg] $msg \
	    [catch {fileevent $f2 readable}] \
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}

# Execute these tests only if the "testfevent" command is present.
testConstraint testfevent [llength [info commands testfevent]]

test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent} {
    testfevent create
    testfevent cmd {
        set f [open foo r]
        set x "no event"
        fileevent $f readable [namespace code {
            set x "f triggered: [gets $f]"
            fileevent $f readable {}
        }]
    }
    after 1	;# We must delay because Windows takes a little time to notice
    update
    testfevent cmd {close $f}
    list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
    testfevent create







|
|





|







5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}

# Execute these tests only if the "testfevent" command is present.
testConstraint testfevent [llength [info commands testfevent]]

test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent} {
    testfevent create
    testfevent cmd [format {
        set f [open %s r]
        set x "no event"
        fileevent $f readable [namespace code {
            set x "f triggered: [gets $f]"
            fileevent $f readable {}
        }]
    } $path(foo)]
    after 1	;# We must delay because Windows takes a little time to notice
    update
    testfevent cmd {close $f}
    list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
    testfevent create
5536
5537
5538
5539
5540
5541
5542
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
        lappend result $x
        update
        lappend result $x
    }
} {0 0 {0 timer}}

test io-47.1 {fileevent vs multiple interpreters} testfevent {
    set f [open foo r]
    set f2 [open foo r]
    set f3 [open foo r]
    fileevent $f readable {script 1}
    testfevent create
    testfevent share $f2
    testfevent cmd "fileevent $f2 readable {script 2}"
    fileevent $f3 readable {sript 3}
    set x {}
    lappend x [fileevent $f2 readable]
    testfevent delete
    lappend x [fileevent $f readable] [fileevent $f2 readable] \
        [fileevent $f3 readable]
    close $f
    close $f2
    close $f3
    set x
} {{} {script 1} {} {sript 3}}
test io-47.2 {deleting fileevent on interpreter delete} testfevent {
    set f [open foo r]
    set f2 [open foo r]
    set f3 [open foo r]
    set f4 [open foo r]
    fileevent $f readable {script 1}
    testfevent create
    testfevent share $f2
    testfevent share $f3
    testfevent cmd "fileevent $f2 readable {script 2}
        fileevent $f3 readable {script 3}"
    fileevent $f4 readable {script 4}
    testfevent delete
    set x [list [fileevent $f readable] [fileevent $f2 readable] \
                [fileevent $f3 readable] [fileevent $f4 readable]]
    close $f
    close $f2
    close $f3
    close $f4
    set x
} {{script 1} {} {} {script 4}}
test io-47.3 {deleting fileevent on interpreter delete} testfevent {
    set f [open foo r]
    set f2 [open foo r]
    set f3 [open foo r]
    set f4 [open foo r]
    testfevent create
    testfevent share $f3
    testfevent share $f4
    fileevent $f readable {script 1}
    fileevent $f2 readable {script 2}
    testfevent cmd "fileevent $f3 readable {script 3}
      fileevent $f4 readable {script 4}"
    testfevent delete
    set x [list [fileevent $f readable] [fileevent $f2 readable] \
                [fileevent $f3 readable] [fileevent $f4 readable]]
    close $f
    close $f2
    close $f3
    close $f4
    set x
} {{script 1} {script 2} {} {}}
test io-47.4 {file events on shared files and multiple interpreters} testfevent {
    set f [open foo r]
    set f2 [open foo r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    fileevent $f2 readable {script 3}
    set x [list [fileevent $f2 readable] \
                [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
    testfevent delete
    close $f
    close $f2
    set x
} {{script 3} {script 1} {script 2}}
test io-47.5 {file events on shared files, deleting file events} testfevent {
    set f [open foo r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    testfevent cmd "fileevent $f readable {}"
    set x [list [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
    testfevent delete
    close $f
    set x
} {{} {script 2}}
test io-47.6 {file events on shared files, deleting file events} testfevent {
    set f [open foo r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    fileevent $f readable {}
    set x [list [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
    testfevent delete
    close $f
    set x
} {{script 1} {}}



test io-48.1 {testing readability conditions} {
    set f [open bar w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f
    set f [open bar r]
    fileevent $f readable [namespace code [list consume $f]]
    proc consume {f} {
	variable l
	variable x
	lappend l called
	if {[eof $f]} {
	    close $f
	    set x done
	} else {
	    gets $f
	}
    }
    set l ""
    variable x not_done
    vwait [namespace which -variable x]
    list $x $l
} {done {called called called called called called called}}
test io-48.2 {testing readability conditions} {nonBlockFiles} {
    set f [open bar w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f
    set f [open bar r]
    fileevent $f readable [namespace code [list consume $f]]
    fconfigure $f -blocking off
    proc consume {f} {
	variable x
	variable l
	lappend l called
	if {[eof $f]} {
	    close $f
	    set x done
	} else {
	    gets $f
	}
    }
    set l ""
    variable x not_done
    vwait [namespace which -variable x]
    list $x $l
} {done {called called called called called called called}}



test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles} {
    set f [open bar w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f
    set f [open my_script w]
    puts $f {
	proc copy_slowly {f} {
	    while {![eof $f]} {
		puts [gets $f]
		after 200
	    }
	    close $f







|
|
|
















|
|
|
|

















|
|
|
|

















|
|














|












|












>
>

|






|


















|






|


















>
>
>

|






|







5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
        lappend result $x
        update
        lappend result $x
    }
} {0 0 {0 timer}}

test io-47.1 {fileevent vs multiple interpreters} testfevent {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    fileevent $f readable {script 1}
    testfevent create
    testfevent share $f2
    testfevent cmd "fileevent $f2 readable {script 2}"
    fileevent $f3 readable {sript 3}
    set x {}
    lappend x [fileevent $f2 readable]
    testfevent delete
    lappend x [fileevent $f readable] [fileevent $f2 readable] \
        [fileevent $f3 readable]
    close $f
    close $f2
    close $f3
    set x
} {{} {script 1} {} {sript 3}}
test io-47.2 {deleting fileevent on interpreter delete} testfevent {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    set f4 [open $path(foo) r]
    fileevent $f readable {script 1}
    testfevent create
    testfevent share $f2
    testfevent share $f3
    testfevent cmd "fileevent $f2 readable {script 2}
        fileevent $f3 readable {script 3}"
    fileevent $f4 readable {script 4}
    testfevent delete
    set x [list [fileevent $f readable] [fileevent $f2 readable] \
                [fileevent $f3 readable] [fileevent $f4 readable]]
    close $f
    close $f2
    close $f3
    close $f4
    set x
} {{script 1} {} {} {script 4}}
test io-47.3 {deleting fileevent on interpreter delete} testfevent {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    set f4 [open $path(foo) r]
    testfevent create
    testfevent share $f3
    testfevent share $f4
    fileevent $f readable {script 1}
    fileevent $f2 readable {script 2}
    testfevent cmd "fileevent $f3 readable {script 3}
      fileevent $f4 readable {script 4}"
    testfevent delete
    set x [list [fileevent $f readable] [fileevent $f2 readable] \
                [fileevent $f3 readable] [fileevent $f4 readable]]
    close $f
    close $f2
    close $f3
    close $f4
    set x
} {{script 1} {script 2} {} {}}
test io-47.4 {file events on shared files and multiple interpreters} testfevent {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    fileevent $f2 readable {script 3}
    set x [list [fileevent $f2 readable] \
                [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
    testfevent delete
    close $f
    close $f2
    set x
} {{script 3} {script 1} {script 2}}
test io-47.5 {file events on shared files, deleting file events} testfevent {
    set f [open $path(foo) r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    testfevent cmd "fileevent $f readable {}"
    set x [list [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
    testfevent delete
    close $f
    set x
} {{} {script 2}}
test io-47.6 {file events on shared files, deleting file events} testfevent {
    set f [open $path(foo) r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    fileevent $f readable {}
    set x [list [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
    testfevent delete
    close $f
    set x
} {{script 1} {}}

set path(bar) [makeFile {} bar]

test io-48.1 {testing readability conditions} {
    set f [open $path(bar) w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f
    set f [open $path(bar) r]
    fileevent $f readable [namespace code [list consume $f]]
    proc consume {f} {
	variable l
	variable x
	lappend l called
	if {[eof $f]} {
	    close $f
	    set x done
	} else {
	    gets $f
	}
    }
    set l ""
    variable x not_done
    vwait [namespace which -variable x]
    list $x $l
} {done {called called called called called called called}}
test io-48.2 {testing readability conditions} {nonBlockFiles} {
    set f [open $path(bar) w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f
    set f [open $path(bar) r]
    fileevent $f readable [namespace code [list consume $f]]
    fconfigure $f -blocking off
    proc consume {f} {
	variable x
	variable l
	lappend l called
	if {[eof $f]} {
	    close $f
	    set x done
	} else {
	    gets $f
	}
    }
    set l ""
    variable x not_done
    vwait [namespace which -variable x]
    list $x $l
} {done {called called called called called called called}}

set path(my_script) [makeFile {} my_script]

test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles} {
    set f [open $path(bar) w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f
    set f [open $path(my_script) w]
    puts $f {
	proc copy_slowly {f} {
	    while {![eof $f]} {
		puts [gets $f]
		after 200
	    }
	    close $f
5729
5730
5731
5732
5733
5734
5735
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
	    lappend l [fblocked $f]
	    gets $f
	    lappend l [fblocked $f]
	}
    }
    set l ""
    variable x not_done
    puts $f {source my_script}
    puts $f {set f [open bar r]}
    puts $f {copy_slowly $f}
    puts $f {exit}
    vwait [namespace which -variable x]
    close $f
    list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -translation auto -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation auto
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation lf
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -translation lf -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation cr
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable c
	variable x
	variable l
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -translation cr -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable c
	variable x
	variable l
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -eofchar \x1a -translation crlf
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable c
	variable x
	variable l
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open test1 r]
    fconfigure $f -translation crlf -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}

test io-49.1 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open test1 r]
    set l ""
    lappend l [file size test1]
    fconfigure $f -translation crlf
    lappend l [read $f 1]
    lappend l [tell $f]
    lappend l [read $f 1]
    lappend l [tell $f]
    lappend l [read $f 1]
    lappend l [tell $f]







|
|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|








|


















|









|



|

|







5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
	    lappend l [fblocked $f]
	    gets $f
	    lappend l [fblocked $f]
	}
    }
    set l ""
    variable x not_done
    puts $f [format {source %s}         $path(my_script)]
    puts $f [format {set f [open %s r]} $path(bar)]
    puts $f {copy_slowly $f}
    puts $f {exit}
    vwait [namespace which -variable x]
    close $f
    list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -translation auto -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable c
	variable x
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation lf
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -translation lf -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable l
	variable x
	variable c
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation cr
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation cr
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable c
	variable x
	variable l
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -translation cr -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%cfoo\nbar\n" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable c
	variable x
	variable l
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation crlf
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation crlf
    set c [format "abc\ndef\n%c" 26]
    puts -nonewline $f $c
    close $f
    proc consume {f} {
	variable c
	variable x
	variable l
	if {[eof $f]} {
	   set x done
	   close $f
	} else {
	   lappend l [gets $f]
	   incr c
	}
    }
    set c 0
    set l ""
    set f [open $path(test1) r]
    fconfigure $f -translation crlf -eofchar \x1a
    fileevent $f readable [namespace code [list consume $f]]
    variable x
    vwait [namespace which -variable x]
    list $c $l
} {3 {abc def {}}}

test io-49.1 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [file size $path(test1)]
    fconfigure $f -translation crlf
    lappend l [read $f 1]
    lappend l [tell $f]
    lappend l [read $f 1]
    lappend l [tell $f]
    lappend l [read $f 1]
    lappend l [tell $f]
6105
6106
6107
6108
6109
6110
6111
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
    lappend l [eof $f]
    close $f
    set l
} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open test1 r]
    set l ""
    lappend l [file size test1]
    fconfigure $f -translation crlf
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [eof $f]
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open test1 r]
    set l ""
    lappend l [file size test1]
    fconfigure $f -translation crlf
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [eof $f]
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
test io-49.4 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open test1 r]
    set l ""
    lappend l [file size test1]
    fconfigure $f -translation crlf
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
test io-49.5 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open test1 w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open test1 r]
    set l ""
    lappend l [file size test1]
    fconfigure $f -translation crlf
    lappend l [set x [gets $f]]
    lappend l [tell $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} [list 7 a\rb\rc 7 {} 7 1]
    
testConstraint testchannelevent [llength [info commands testchannelevent]]
test io-50.1 {testing handler deletion} {testchannelevent} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    testchannelevent $f add readable [namespace code [list delhandler $f]]
    proc delhandler {f} {
	variable z
	set z called
	testchannelevent $f delete 0
    }
    set z not_called
    update
    close $f
    set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
	variable z
	lappend z "called delhandler $f $i"
	testchannelevent $f delete 0
    }
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    set z ""
    proc notcalled {f i} {
	variable z
	lappend z "notcalled was called!! $f $i"
    }







|



|

|
















|



|

|














|



|

|














|



|

|













|

|













|

|















|

|







6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
    lappend l [eof $f]
    close $f
    set l
} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [file size $path(test1)]
    fconfigure $f -translation crlf
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [eof $f]
    lappend l [read $f 2]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [file size $path(test1)]
    fconfigure $f -translation crlf
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [eof $f]
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
test io-49.4 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [file size $path(test1)]
    fconfigure $f -translation crlf
    lappend l [read $f 3]
    lappend l [tell $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
test io-49.5 {testing crlf reading, leftover cr disgorgment} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts -nonewline $f "a\rb\rc\r\n"
    close $f
    set f [open $path(test1) r]
    set l ""
    lappend l [file size $path(test1)]
    fconfigure $f -translation crlf
    lappend l [set x [gets $f]]
    lappend l [tell $f]
    lappend l [gets $f]
    lappend l [tell $f]
    lappend l [eof $f]
    close $f
    set l
} [list 7 a\rb\rc 7 {} 7 1]
    
testConstraint testchannelevent [llength [info commands testchannelevent]]
test io-50.1 {testing handler deletion} {testchannelevent} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f]]
    proc delhandler {f} {
	variable z
	set z called
	testchannelevent $f delete 0
    }
    set z not_called
    update
    close $f
    set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delhandler $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    proc delhandler {f i} {
	variable z
	lappend z "called delhandler $f $i"
	testchannelevent $f delete 0
    }
    set z ""
    update
    close $f
    string compare [string tolower $z] \
	[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f 1]]
    testchannelevent $f add readable [namespace code [list delhandler $f 0]]
    set z ""
    proc notcalled {f i} {
	variable z
	lappend z "notcalled was called!! $f $i"
    }
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
    close $f
    string compare [string tolower $z] \
	[list [list delhandler $f 0 called] \
	      [list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    testchannelevent $f add readable [namespace code [list delrecursive $f]]
    proc delrecursive {f} {
	variable z
	variable u
	if {"$u" == "recursive"} {
	    testchannelevent $f delete 0
	    lappend z "delrecursive deleting recursive"







|

|







6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
    close $f
    string compare [string tolower $z] \
	[list [list delhandler $f 0 called] \
	      [list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list delrecursive $f]]
    proc delrecursive {f} {
	variable z
	variable u
	if {"$u" == "recursive"} {
	    testchannelevent $f delete 0
	    lappend z "delrecursive deleting recursive"
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
    update
    close $f
    string compare [string tolower $z] \
	{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
    proc del {f} {







|

|







6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
    update
    close $f
    string compare [string tolower $z] \
	{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list notcalled $f]]
    testchannelevent $f add readable [namespace code [list del $f]]
    proc notcalled {f} {
	variable z
	lappend z "notcalled was called!! $f"
    }
    proc del {f} {
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
    close $f
    string compare [string tolower $z] \
	[list {del calling recursive} {del deleted notcalled} \
	      {del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
    removeFile test1
    set f [open test1 w]
    close $f
    set f [open test1 r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
	variable u
	variable z
	if {"$u" == "toplevel"} {
	    lappend z "first called"







|

|







6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
    close $f
    string compare [string tolower $z] \
	[list {del calling recursive} {del deleted notcalled} \
	      {del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
    removeFile test1
    set f [open $path(test1) w]
    close $f
    set f [open $path(test1) r]
    testchannelevent $f add readable [namespace code [list second $f]]
    testchannelevent $f add readable [namespace code [list first $f]]
    proc first {f} {
	variable u
	variable z
	if {"$u" == "toplevel"} {
	    lappend z "first called"
6393
6394
6395
6396
6397
6398
6399
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
    close $ss
    set result
} {sock1 sock2 sock3 sock4}

test io-52.1 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fcopy $f1 $f2 -command { # }
    catch { fcopy $f1 $f2 } msg
    close $f1
    close $f2
    string compare $msg "channel \"$f1\" is busy"
} {0}
test io-52.2 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    set f3 [open $thisScript]
    fcopy $f1 $f2 -command { # }
    catch { fcopy $f3 $f2 } msg
    close $f1
    close $f2
    close $f3
    string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    set s0 [fcopy $f1 $f2]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size test1]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 40
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    lappend result [file size test1]
} {0 0 40}
test io-52.5 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    fcopy $f1 $f2 -size -1
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size test1]
    if {"$s1" == "$s2"} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.6 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size test1]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.7 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    fcopy $f1 $f2
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    set s1 [file size $thisScript]
    set s2 [file size test1]
    close $f1
    close $f2
    if {"$s1" == "$s2"} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    fconfigure $f1 -translation lf
    puts $f1 "
	puts ready
	gets stdin
	set f1 \[open [list $thisScript] r\]
	fconfigure \$f1 -translation lf
	puts \[read \$f1 100\]
	close \$f1
    "
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    fconfigure $f1 -translation lf
    gets $f1
    puts $f1 ready
    flush $f1
    set f2 [open test1 w]
    fconfigure $f2 -translation lf
    set s0 [fcopy $f1 $f2 -size 40]
    catch {close $f1}
    close $f2
    list $s0 [file size test1]
} {40 40}

# Empty files, to register them with the test facility
makeFile {} kyrillic.txt
makeFile {} utf8-fcopy.txt
makeFile {} utf8-rp.txt

# Create kyrillic file, use lf translation to avoid os eol issues
set out [open kyrillic.txt w]
fconfigure $out -encoding koi8-r -translation lf
puts       $out "\u0410\u0410"
close      $out

test io-52.9 {TclCopyChannel & encodings} {
    # Copy kyrillic to UTF-8, using fcopy.

    set in  [open kyrillic.txt r]
    set out [open utf8-fcopy.txt w]

    fconfigure $in  -encoding koi8-r -translation lf
    fconfigure $out -encoding utf-8 -translation lf

    fcopy $in $out
    close $in
    close $out

    # Do the same again, but differently (read/puts).

    set in  [open kyrillic.txt r]
    set out [open utf8-rp.txt w]

    fconfigure $in  -encoding koi8-r -translation lf
    fconfigure $out -encoding utf-8 -translation lf

    puts -nonewline $out [read $in]

    close $in
    close $out

    list [file size kyrillic.txt] \
	    [file size utf8-fcopy.txt] \
	    [file size utf8-rp.txt]
} {3 5 5}

test io-52.10 {TclCopyChannel & encodings} {
    # encoding to binary (=> implies that the
    # internal utf-8 is written)

    set in  [open kyrillic.txt r]
    set out [open utf8-fcopy.txt w]

    fconfigure $in  -encoding koi8-r -translation lf
    # -translation binary is also -encoding binary
    fconfigure $out -translation binary

    fcopy $in $out
    close $in
    close $out

    file size utf8-fcopy.txt
} 5

test io-52.11 {TclCopyChannel & encodings} {
    # binary to encoding => the input has to be
    # in utf-8 to make sense to the encoder

    set in  [open utf8-fcopy.txt r]
    set out [open kyrillic.txt w]

    # -translation binary is also -encoding binary
    fconfigure $in  -translation binary
    fconfigure $out -encoding koi8-r -translation lf

    fcopy $in $out
    close $in
    close $out

    file size kyrillic.txt
} 3


test io-53.1 {CopyData} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 0
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    lappend result [file size test1]
} {0 0 0}
test io-53.2 {CopyData} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open test1 w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -command [namespace code {set s0}]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    variable s0
    vwait [namespace which -variable s0]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size test1]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unixOnly} {
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	puts ready
	flush stdout				;# Don't assume line buffered!
	fcopy stdin stdout -command { set x }
	vwait x
	set f [open test1 w]
	fconfigure $f -translation lf
	puts $f "done"
	close $f
    }
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    set result [gets $f1]
    puts $f1 line1
    flush $f1
    lappend result [gets $f1]
    puts $f1 line2
    flush $f1
    lappend result [gets $f1]
    close $f1
    after 500
    set f [open test1]
    lappend result [read $f]
    close $f
    set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unixOnly} {
    set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
    variable x
    for {set x 0} {$x < 12} {incr x} {
	append big $big
    }
    removeFile test1
    removeFile pipe
    set f1 [open pipe w]
    puts $f1 {
	puts ready
	fcopy stdin stdout -command { set x }
	vwait x
	set f [open test1 w]
	fconfigure $f -translation lf
	puts $f "done"
	close $f
    }
    close $f1
    set f1 [open "|[list [interpreter] pipe]" r+]
    set result [gets $f1]
    fconfigure $f1 -blocking 0
    puts $f1 $big
    flush $f1
    after 500
    set result ""
    fileevent $f1 read [namespace code {







|









|











|







|








|






|




|







|








|







|








|





|










|










|




|




|



|
|
|


|







|
|










|
|









|
|
|






|
|









|






|
|









|






|






|




|









|








|
|




|



|

|









|












|




|





|







6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
    close $ss
    set result
} {sock1 sock2 sock3 sock4}

test io-52.1 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fcopy $f1 $f2 -command { # }
    catch { fcopy $f1 $f2 } msg
    close $f1
    close $f2
    string compare $msg "channel \"$f1\" is busy"
} {0}
test io-52.2 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    set f3 [open $thisScript]
    fcopy $f1 $f2 -command { # }
    catch { fcopy $f3 $f2 } msg
    close $f1
    close $f2
    close $f3
    string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    set s0 [fcopy $f1 $f2]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 40
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    lappend result [file size $path(test1)]
} {0 0 40}
test io-52.5 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    fcopy $f1 $f2 -size -1
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {"$s1" == "$s2"} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.6 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.7 {TclCopyChannel} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation lf -blocking 0
    fcopy $f1 $f2
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    close $f1
    close $f2
    if {"$s1" == "$s2"} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio} {
    removeFile test1
    removeFile pipe
    set f1 [open $path(pipe) w]
    fconfigure $f1 -translation lf
    puts $f1 "
	puts ready
	gets stdin
	set f1 \[open [list $thisScript] r\]
	fconfigure \$f1 -translation lf
	puts \[read \$f1 100\]
	close \$f1
    "
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f1 -translation lf
    gets $f1
    puts $f1 ready
    flush $f1
    set f2 [open $path(test1) w]
    fconfigure $f2 -translation lf
    set s0 [fcopy $f1 $f2 -size 40]
    catch {close $f1}
    close $f2
    list $s0 [file size $path(test1)]
} {40 40}

# Empty files, to register them with the test facility
set path(kyrillic.txt)   [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
set path(utf8-rp.txt)    [makeFile {} utf8-rp.txt]

# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
fconfigure $out -encoding koi8-r -translation lf
puts       $out "\u0410\u0410"
close      $out

test io-52.9 {TclCopyChannel & encodings} {
    # Copy kyrillic to UTF-8, using fcopy.

    set in  [open $path(kyrillic.txt) r]
    set out [open $path(utf8-fcopy.txt) w]

    fconfigure $in  -encoding koi8-r -translation lf
    fconfigure $out -encoding utf-8 -translation lf

    fcopy $in $out
    close $in
    close $out

    # Do the same again, but differently (read/puts).

    set in  [open $path(kyrillic.txt) r]
    set out [open $path(utf8-rp.txt) w]

    fconfigure $in  -encoding koi8-r -translation lf
    fconfigure $out -encoding utf-8 -translation lf

    puts -nonewline $out [read $in]

    close $in
    close $out

    list [file size $path(kyrillic.txt)] \
	    [file size $path(utf8-fcopy.txt)] \
	    [file size $path(utf8-rp.txt)]
} {3 5 5}

test io-52.10 {TclCopyChannel & encodings} {
    # encoding to binary (=> implies that the
    # internal utf-8 is written)

    set in  [open $path(kyrillic.txt) r]
    set out [open $path(utf8-fcopy.txt) w]

    fconfigure $in  -encoding koi8-r -translation lf
    # -translation binary is also -encoding binary
    fconfigure $out -translation binary

    fcopy $in $out
    close $in
    close $out

    file size $path(utf8-fcopy.txt)
} 5

test io-52.11 {TclCopyChannel & encodings} {
    # binary to encoding => the input has to be
    # in utf-8 to make sense to the encoder

    set in  [open $path(utf8-fcopy.txt) r]
    set out [open $path(kyrillic.txt) w]

    # -translation binary is also -encoding binary
    fconfigure $in  -translation binary
    fconfigure $out -encoding koi8-r -translation lf

    fcopy $in $out
    close $in
    close $out

    file size $path(kyrillic.txt)
} 3


test io-53.1 {CopyData} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -size 0
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    lappend result [file size $path(test1)]
} {0 0 0}
test io-53.2 {CopyData} {
    removeFile test1
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -blocking 0
    fconfigure $f2 -translation cr -blocking 0
    fcopy $f1 $f2 -command [namespace code {set s0}]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    variable s0
    vwait [namespace which -variable s0]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unixOnly} {
    removeFile test1
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 [format {
	puts ready
	flush stdout				;# Don't assume line buffered!
	fcopy stdin stdout -command { set x }
	vwait x
	set f [open "%s" w]
	fconfigure $f -translation lf
	puts $f "done"
	close $f
    } $path(test1)]
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set result [gets $f1]
    puts $f1 line1
    flush $f1
    lappend result [gets $f1]
    puts $f1 line2
    flush $f1
    lappend result [gets $f1]
    close $f1
    after 500
    set f [open $path(test1)]
    lappend result [read $f]
    close $f
    set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unixOnly} {
    set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
    variable x
    for {set x 0} {$x < 12} {incr x} {
	append big $big
    }
    removeFile test1
    removeFile pipe
    set f1 [open $path(pipe) w]
    puts $f1 {
	puts ready
	fcopy stdin stdout -command { set x }
	vwait x
	set f [open $path(test1) w]
	fconfigure $f -translation lf
	puts $f "done"
	close $f
    }
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set result [gets $f1]
    fconfigure $f1 -blocking 0
    puts $f1 $big
    flush $f1
    after 500
    set result ""
    fileevent $f1 read [namespace code {
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
    set fcopyTestDone	;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio} {
    variable fcopyTestDone
    removeFile pipe
    removeFile test1
    catch {unset fcopyTestDone}
    set f1 [open pipe w]
    puts $f1 "exit 1"
    close $f1
    set in [open "|[list [interpreter] pipe]" r+]
    set out [open test1 w]
    fcopy $in $out -command [namespace code FcopyTestDone]
    variable fcopyTestDone
    if ![info exists fcopyTestDone] {
	vwait [namespace which -variable fcopyTestDone]
    }
    catch {close $in}
    close $out







|


|
|







6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
    set fcopyTestDone	;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio} {
    variable fcopyTestDone
    removeFile pipe
    removeFile test1
    catch {unset fcopyTestDone}
    set f1 [open $path(pipe) w]
    puts $f1 "exit 1"
    close $f1
    set in [open "|[list [interpreter] $path(pipe)]" r+]
    set out [open $path(test1) w]
    fcopy $in $out -command [namespace code FcopyTestDone]
    variable fcopyTestDone
    if ![info exists fcopyTestDone] {
	vwait [namespace which -variable fcopyTestDone]
    }
    catch {close $in}
    close $out
6769
6770
6771
6772
6773
6774
6775
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

test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
    variable fcopyTestDone
    removeFile pipe
    removeFile test1
    catch {unset fcopyTestDone}
    set fcopyTestCount 0
    set f1 [open pipe w]
    puts $f1 {
	# Write  10 bytes / 10 msec
	proc Write {count} {
	    puts -nonewline "1234567890"
	    if {[incr count -1]} {
	        after 10 [list Write $count]
	    } else {
	        set ::ready 1
	    }
	}
	fconfigure stdout -buffering none
	Write 345 ;# 3450 bytes ~3.45 sec
	vwait ready
	exit 0
    }
    close $f1
    set in [open "|[list [interpreter] pipe &]" r+]
    set out [open test1 w]
    doFcopy $in $out
    variable fcopyTestDone
    if ![info exists fcopyTestDone] {
	vwait [namespace which -variable fcopyTestDone]
    }
    catch {close $in}
    close $out







|
















|
|







6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833

test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
    variable fcopyTestDone
    removeFile pipe
    removeFile test1
    catch {unset fcopyTestDone}
    set fcopyTestCount 0
    set f1 [open $path(pipe) w]
    puts $f1 {
	# Write  10 bytes / 10 msec
	proc Write {count} {
	    puts -nonewline "1234567890"
	    if {[incr count -1]} {
	        after 10 [list Write $count]
	    } else {
	        set ::ready 1
	    }
	}
	fconfigure stdout -buffering none
	Write 345 ;# 3450 bytes ~3.45 sec
	vwait ready
	exit 0
    }
    close $f1
    set in [open "|[list [interpreter] $path(pipe) &]" r+]
    set out [open $path(test1) w]
    doFcopy $in $out
    variable fcopyTestDone
    if ![info exists fcopyTestDone] {
	vwait [namespace which -variable fcopyTestDone]
    }
    catch {close $in}
    close $out
6912
6913
6914
6915
6916
6917
6918


6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
    vwait [namespace which -variable done]
    close $writer
    close $s
    after cancel $after
    if {$accept != {}} {close $accept}
    set counter
} 1



test io-55.1 {ChannelEventScriptInvoker: deletion} {
    variable x
    proc eventScript {fd} {
	variable x
	close $fd
	error "planned error"
	set x whoops
    }
    proc ::bgerror {args} "set [namespace which -variable x] got_error"
    set f [open fooBar w]
    fileevent $f writable [namespace code [list eventScript $f]]
    variable x not_done
    vwait [namespace which -variable x]
    set x
} {got_error}

test io-56.1 {ChannelTimerProc} {testchannelevent} {
    set f [open fooBar w]
    puts $f "this is a test"
    close $f
    set f [open fooBar r]
    testchannelevent $f add readable [namespace code {
	read $f 1
	incr x
    }]
    variable x 0
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]







>
>










|







|


|







6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
    vwait [namespace which -variable done]
    close $writer
    close $s
    after cancel $after
    if {$accept != {}} {close $accept}
    set counter
} 1

set path(fooBar) [makeFile {} fooBar]

test io-55.1 {ChannelEventScriptInvoker: deletion} {
    variable x
    proc eventScript {fd} {
	variable x
	close $fd
	error "planned error"
	set x whoops
    }
    proc ::bgerror {args} "set [namespace which -variable x] got_error"
    set f [open $path(fooBar) w]
    fileevent $f writable [namespace code [list eventScript $f]]
    variable x not_done
    vwait [namespace which -variable x]
    set x
} {got_error}

test io-56.1 {ChannelTimerProc} {testchannelevent} {
    set f [open $path(fooBar) w]
    puts $f "this is a test"
    close $f
    set f [open $path(fooBar) r]
    testchannelevent $f add readable [namespace code {
	read $f 1
	incr x
    }]
    variable x 0
    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
6998
6999
7000
7001
7002
7003
7004
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
    close $s
    close $s2
    close $server
    set result
} {1 readable 234567890 timer}
        
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc} {
    set out [open script w]
    puts $out {
	puts "normal message from pipe"
	puts stderr "error message from pipe"
	exit 1
    }
    proc readit {pipe} {
	variable x
	variable result
	if {[eof $pipe]} {
	    set x [catch {close $pipe} line]
	    lappend result catch $line
	} else {
	    gets $pipe line
	    lappend result gets $line
	}
    }
    close $out
    set pipe [open "|[list [interpreter]] script" r]
    fileevent $pipe readable [namespace code [list readit $pipe]]
    variable x ""
    set result ""
    vwait [namespace which -variable x]
    list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}


testConstraint testmainthread [llength [info commands testmainthread]]
test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
    # TIP #10
    # More complicated tests (like that the reference changes as a
    # channel is moved from thread to thread) can be done only in the
    # extension which fully implements the moving of channels between
    # threads, i.e. 'Threads'. Or we have to extend [testthread] as well.

    set f [open longfile r]
    set result [testchannel mthread $f]
    close $f
    string equal $result [testmainthread]
} {1}




































# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return







|

















|
















|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










7032
7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
7048
7049
7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
    close $s
    close $s2
    close $server
    set result
} {1 readable 234567890 timer}
        
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc} {
    set out [open $path(script) w]
    puts $out {
	puts "normal message from pipe"
	puts stderr "error message from pipe"
	exit 1
    }
    proc readit {pipe} {
	variable x
	variable result
	if {[eof $pipe]} {
	    set x [catch {close $pipe} line]
	    lappend result catch $line
	} else {
	    gets $pipe line
	    lappend result gets $line
	}
    }
    close $out
    set pipe [open "|[list [interpreter] $path(script)]" r]
    fileevent $pipe readable [namespace code [list readit $pipe]]
    variable x ""
    set result ""
    vwait [namespace which -variable x]
    list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}


testConstraint testmainthread [llength [info commands testmainthread]]
test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
    # TIP #10
    # More complicated tests (like that the reference changes as a
    # channel is moved from thread to thread) can be done only in the
    # extension which fully implements the moving of channels between
    # threads, i.e. 'Threads'. Or we have to extend [testthread] as well.

    set f [open $path(longfile) r]
    set result [testchannel mthread $f]
    close $f
    string equal $result [testmainthread]
} {1}


test io-60.1 {writing illegal utf sequences} {
    # This test will hang in older revisions of the core.

    set out [open $path(script) w]
    puts $out {
	puts [encoding convertfrom identity \xe2]
	exit 1
    }
    proc readit {pipe} {
	variable x
	variable result
	if {[eof $pipe]} {
	    set x [catch {close $pipe} line]
	    lappend result catch $line
	} else {
	    gets $pipe line
	    lappend result gets $line
	}
    }
    close $out
    set pipe [open "|[list [interpreter] $path(script)]" r]
    fileevent $pipe readable [namespace code [list readit $pipe]]
    variable x ""
    set result ""
    vwait [namespace which -variable x]

    # cut of the remainder of the error stack, especially the filename
    set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
    list $x $result
} {1 {gets {} catch {error writing "stdout": invalid argument}}}




# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
Changes to tests/ioCmd.test.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41



42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.11.2.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

removeFile test1
removeFile pipe

set executable [list [info nameofexecutable]]

test iocmd-1.1 {puts command} {
   list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
   list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.3 {puts command} {
   list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {bad argument "kablooie": should be "nonewline"}}
test iocmd-1.4 {puts command} {
   list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
   list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}



test iocmd-1.6 {puts command} {
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    puts -nonewline $f foobar
    close $f
    file size test1
} 6
test iocmd-1.7 {puts command} {
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    puts $f foobar
    close $f
    file size test1
} 7
test iocmd-1.8 {puts command} {
    set f [open test1 w]
    fconfigure $f -translation lf -eofchar {}
    puts -nonewline $f [binary format a4a5 foo bar]
    close $f
    file size test1
} 9


test iocmd-2.1 {flush command} {
   list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.2 {flush command} {







|









<
<















>
>
>

|



|


|



|


|



|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24


25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.11.2.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

removeFile test1
removeFile pipe



test iocmd-1.1 {puts command} {
   list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
   list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.3 {puts command} {
   list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {bad argument "kablooie": should be "nonewline"}}
test iocmd-1.4 {puts command} {
   list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
   list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}

set path(test1) [makeFile {} test1]

test iocmd-1.6 {puts command} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    puts -nonewline $f foobar
    close $f
    file size $path(test1)
} 6
test iocmd-1.7 {puts command} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f foobar
    close $f
    file size $path(test1)
} 7
test iocmd-1.8 {puts command} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    puts -nonewline $f [binary format a4a5 foo bar]
    close $f
    file size $path(test1)
} 9


test iocmd-2.1 {flush command} {
   list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.2 {flush command} {
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
test iocmd-3.3 {gets command} {
   list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
   list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
    set f [open test1 w]
    puts $f [binary format a4a5 foo bar]
    close $f
    set f [open test1 r]
    set result [gets $f]
    close $f
    set x foo\x00
    set x "${x}bar\x00\x00"
    string compare $x $result
} 0








|


|







85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
test iocmd-3.3 {gets command} {
   list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
   list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
    set f [open $path(test1) w]
    puts $f [binary format a4a5 foo bar]
    close $f
    set f [open $path(test1) r]
    set result [gets $f]
    close $f
    set x foo\x00
    set x "${x}bar\x00\x00"
    string compare $x $result
} 0

118
119
120
121
122
123
124
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
   list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
   list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
    removeFile test1
    set f [open test1 w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open test1]
    set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode]
    close $f
    set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
test iocmd-4.9 {read command} {
    list [catch {read stdin foo} msg] $msg $errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
    list [catch {read file107} msg] $msg $errorCode
} {1 {can not find channel named "file107"} NONE}



test iocmd-4.11 {read command} {
    set f [open test3 w]
    set x [list [catch {read $f} msg] $msg $errorCode]
    close $f
    string compare [string tolower $x] \
	[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
    set f [open test1]
    set x [list [catch {read $f 12z} msg] $msg $errorCode]
    close $f
    set x
} {1 {expected integer but got "12z"} NONE}

test iocmd-5.1 {seek command} {
    list [catch {seek} msg] $msg







|



|










>
>
>

|






|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
   list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
   list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1)]
    set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode]
    close $f
    set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
test iocmd-4.9 {read command} {
    list [catch {read stdin foo} msg] $msg $errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
    list [catch {read file107} msg] $msg $errorCode
} {1 {can not find channel named "file107"} NONE}

set path(test3) [makeFile {} test3]

test iocmd-4.11 {read command} {
    set f [open $path(test3) w]
    set x [list [catch {read $f} msg] $msg $errorCode]
    close $f
    string compare [string tolower $x] \
	[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
    set f [open $path(test1)]
    set x [list [catch {read $f 12z} msg] $msg $errorCode]
    close $f
    set x
} {1 {expected integer but got "12z"} NONE}

test iocmd-5.1 {seek command} {
    list [catch {seek} msg] $msg
191
192
193
194
195
196
197
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
    list [catch {fconfigure a b c d e f} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
test iocmd-8.3 {fconfigure command} {
    list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
    removeFile test1
    set f1 [open test1 w]
    set x [list [catch {fconfigure $f1 froboz} msg] $msg]
    close $f1
    set x
} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.5 {fconfigure command} {
    list [catch {fconfigure stdin -buffering froboz} msg] $msg
} {1 {bad value for -buffering: must be one of full, line, or none}}
test iocmd-8.6 {fconfigure command} {
    list [catch {fconfigure stdin -translation froboz} msg] $msg
} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
test iocmd-8.7 {fconfigure command} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -eofchar {} -encoding unicode
    set x [fconfigure $f1]
    close $f1
    set x
} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
		-eofchar {} -encoding unicode
    set x ""
    lappend x [fconfigure $f1 -buffering]
    lappend x [fconfigure $f1]
    close $f1
    set x
} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} {
    removeFile test1
    set f1 [open test1 w]
    fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
		-eofchar {} -encoding binary
    set x [fconfigure $f1]
    close $f1
    set x
} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
test iocmd-8.10 {fconfigure command} {
    list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}

makeFile {} fconfigure.dummy

test iocmd-8.11 {fconfigure command} {
    set chan [open fconfigure.dummy r]
    set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
    close $chan
    set res
} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}

test iocmd-8.12 {fconfigure command} {
    set chan [open fconfigure.dummy r]
    set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
    close $chan
    set res
} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}

test iocmd-8.13 {fconfigure command} {
    set chan [open fconfigure.dummy r]
    set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
    close $chan
    set res
} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}

removeFile fconfigure.dummy








|












|







|










|










|


|






|






|







195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
    list [catch {fconfigure a b c d e f} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
test iocmd-8.3 {fconfigure command} {
    list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
    removeFile test1
    set f1 [open $path(test1) w]
    set x [list [catch {fconfigure $f1 froboz} msg] $msg]
    close $f1
    set x
} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.5 {fconfigure command} {
    list [catch {fconfigure stdin -buffering froboz} msg] $msg
} {1 {bad value for -buffering: must be one of full, line, or none}}
test iocmd-8.6 {fconfigure command} {
    list [catch {fconfigure stdin -translation froboz} msg] $msg
} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
test iocmd-8.7 {fconfigure command} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -eofchar {} -encoding unicode
    set x [fconfigure $f1]
    close $f1
    set x
} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
		-eofchar {} -encoding unicode
    set x ""
    lappend x [fconfigure $f1 -buffering]
    lappend x [fconfigure $f1]
    close $f1
    set x
} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} {
    removeFile test1
    set f1 [open $path(test1) w]
    fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
		-eofchar {} -encoding binary
    set x [fconfigure $f1]
    close $f1
    set x
} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
test iocmd-8.10 {fconfigure command} {
    list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}

set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]

test iocmd-8.11 {fconfigure command} {
    set chan [open $path(fconfigure.dummy) r]
    set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
    close $chan
    set res
} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}

test iocmd-8.12 {fconfigure command} {
    set chan [open $path(fconfigure.dummy) r]
    set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
    close $chan
    set res
} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}

test iocmd-8.13 {fconfigure command} {
    set chan [open $path(fconfigure.dummy) r]
    set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
    close $chan
    set res
} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}

removeFile fconfigure.dummy

354
355
356
357
358
359
360



361
362
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
test iocmd-10.4 {fblocked command} {
    list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {
    fblocked stdin
} 0




removeFile test5
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
    set f [open test4 w]
    close $f
    list [catch {open "| cat < test4 > test5" w} msg] $msg $errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > test5" r} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > test5" r+} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    removeFile test1
    set f [open test1 w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open test1 RDONLY]
    set x [list [gets $f] [catch {puts $f Test} msg] $msg]
    close $f
    string compare $x \
	"{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]"
} 0
test iocmd-12.2 {POSIX open access modes: RDONLY} {
    removeFile test3
    set msg [list [catch {open test3 RDONLY} msg] $msg]
    regsub [file join {} test3] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.3 {POSIX open access modes: WRONLY} {
    removeFile test3
    set msg [list [catch {open test3 WRONLY} msg] $msg]
    regsub [file join {} test3] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} {
    removeFile test3
    set f [open test3 w]
    fconfigure $f -eofchar {}
    puts $f xyzzy
    close $f
    set f [open test3 WRONLY]
    fconfigure $f -eofchar {}
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [list [catch {gets $f} msg] $msg]
    close $f
    set f [open test3 r]
    fconfigure $f -eofchar {}
    lappend x [gets $f]
    close $f
    set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy]
    string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} {
    removeFile test3
    set msg [list [catch {open test3 RDWR} msg] $msg]
    regsub [file join {} test3] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.6 {POSIX open access modes: errors} {
    concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open test3 \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open test3 {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
    list [catch {open test3 {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}

test iocmd-13.1 {errors in open command} {
    list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
    list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.3 {errors in open command} {
    list [catch {open test1 x} msg] $msg
} {1 {illegal access mode "x"}}
test iocmd-13.4 {errors in open command} {
    list [catch {open test1 rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
    list [catch {open 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}}}








>
>
>


|

|


|


|




|



|







|
|




|
|







|



|





|








|
|



|




|

|


|









|


|


|







358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
test iocmd-10.4 {fblocked command} {
    list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {
    fblocked stdin
} 0

set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]

removeFile test5
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
    set f [open $path(test4) w]
    close $f
    list [catch {open "| cat < $path(test4) > $path(test5)" w} msg] $msg $errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > $path(test5)" r} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > $path(test5)" r+} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    removeFile test1
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
    puts $f "and this one"
    close $f
    set f [open $path(test1) RDONLY]
    set x [list [gets $f] [catch {puts $f Test} msg] $msg]
    close $f
    string compare $x \
	"{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]"
} 0
test iocmd-12.2 {POSIX open access modes: RDONLY} {
    removeFile test3
    set msg [list [catch {open $path(test3) RDONLY} msg] $msg]
    regsub [file join {} $path(test3)] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.3 {POSIX open access modes: WRONLY} {
    removeFile test3
    set msg [list [catch {open $path(test3) WRONLY} msg] $msg]
    regsub [file join {} $path(test3)] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} {
    removeFile test3
    set f [open $path(test3) w]
    fconfigure $f -eofchar {}
    puts $f xyzzy
    close $f
    set f [open $path(test3) WRONLY]
    fconfigure $f -eofchar {}
    puts -nonewline $f "ab"
    seek $f 0 current
    set x [list [catch {gets $f} msg] $msg]
    close $f
    set f [open $path(test3) r]
    fconfigure $f -eofchar {}
    lappend x [gets $f]
    close $f
    set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy]
    string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} {
    removeFile test3
    set msg [list [catch {open $path(test3) RDWR} msg] $msg]
    regsub [file join {} $path(test3)] $msg "test3" msg
	string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.6 {POSIX open access modes: errors} {
    concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
    while processing open access modes \"FOO {BAR BAZ\"
    invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
  list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
    list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}

test iocmd-13.1 {errors in open command} {
    list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
    list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.3 {errors in open command} {
    list [catch {open $path(test1) x} msg] $msg
} {1 {illegal access mode "x"}}
test iocmd-13.4 {errors in open command} {
    list [catch {open $path(test1) rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
    list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
    set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
    regsub [file join {} _non_existent_] $msg "_non_existent_" msg
	string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}

481
482
483
484
485
486
487

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
} {0 0}
test iocmd-14.8 {file id parsing errors} {
    list [catch {eof stderr} msg] $msg
} {0 0}
test iocmd-14.9 {file id parsing errors} {
    list [catch {eof stderr1} msg] $msg
} {1 {can not find channel named "stderr1"}}

set f [open test1 w]
close $f

set expect "1 {can not find channel named \"$f\"}"
test iocmd-14.10 {file id parsing errors} {
    list [catch {eof $f} msg] $msg
} $expect

test iocmd-15.1 {Tcl_FcopyObjCmd} {
    list [catch {fcopy} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.2 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.3 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.4 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1 2 3} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.5 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1 2 3 4 5} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}



set f [open test1 w]
close $f

set rfile [open test1 r]
set wfile [open test2 w]

test iocmd-15.6 {Tcl_FcopyObjCmd} {
    list [catch {fcopy foo $wfile} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.7 {Tcl_FcopyObjCmd} {
    list [catch {fcopy $rfile foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.8 {Tcl_FcopyObjCmd} {







>
|

>




















>
>
>
|

>
|
|
>







488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
} {0 0}
test iocmd-14.8 {file id parsing errors} {
    list [catch {eof stderr} msg] $msg
} {0 0}
test iocmd-14.9 {file id parsing errors} {
    list [catch {eof stderr1} msg] $msg
} {1 {can not find channel named "stderr1"}}

set f [open $path(test1) w]
close $f

set expect "1 {can not find channel named \"$f\"}"
test iocmd-14.10 {file id parsing errors} {
    list [catch {eof $f} msg] $msg
} $expect

test iocmd-15.1 {Tcl_FcopyObjCmd} {
    list [catch {fcopy} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.2 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.3 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.4 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1 2 3} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.5 {Tcl_FcopyObjCmd} {
    list [catch {fcopy 1 2 3 4 5} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}

set path(test2) [makeFile {} test2]

set f [open $path(test1) w]
close $f

set rfile [open $path(test1) r]
set wfile [open $path(test2) w]

test iocmd-15.6 {Tcl_FcopyObjCmd} {
    list [catch {fcopy foo $wfile} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.7 {Tcl_FcopyObjCmd} {
    list [catch {fcopy $rfile foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.8 {Tcl_FcopyObjCmd} {
Changes to tests/ioUtil.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(),
# and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found. 
# 
# Copyright (c) 1998-1999 by Scriptics Corporation. 
# 
# See the file "license.terms" for information on usage and redistribution 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 
# 
# RCS: @(#) $Id: ioUtil.test,v 1.10 2001/09/06 23:04:30 hobbs Exp $
 
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(testopenfilechannelproc) \
	[llength [info commands testopenfilechannelproc]]
set ::tcltest::testConstraints(testaccessproc) \
	[llength [info commands testaccessproc]]
set ::tcltest::testConstraints(teststatproc) \
	[llength [info commands teststatproc]]

set unsetScript {
    catch {unset testStat1(size)}
    catch {unset testStat2(size)}
    catch {unset testStat3(size)}
}










|


|



|

|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(),
# and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found. 
# 
# Copyright (c) 1998-1999 by Scriptics Corporation. 
# 
# See the file "license.terms" for information on usage and redistribution 
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 
# 
# RCS: @(#) $Id: ioUtil.test,v 1.10.8.1 2002/08/20 20:25:28 das Exp $
 
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint testopenfilechannelproc \
	[llength [info commands testopenfilechannelproc]]
::tcltest::testConstraint testaccessproc \
	[llength [info commands testaccessproc]]
::tcltest::testConstraint teststatproc \
	[llength [info commands teststatproc]]

set unsetScript {
    catch {unset testStat1(size)}
    catch {unset testStat2(size)}
    catch {unset testStat3(size)}
}
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    file stat testStat3%.fil testStat3

    list $testStat2(size) $testStat1(size) $testStat3(size)
} {2345 1234 3456}

eval $unsetScript

test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletedable.} {
    catch {teststatproc delete TclpStat} err2
    set err2
} {"TclpStat": could not be deleteed}

test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} {
    # Delete the 2nd procedure and test that it longer exists but that
    #   the others do actually return a result.







|







49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    file stat testStat3%.fil testStat3

    list $testStat2(size) $testStat1(size) $testStat3(size)
} {2345 1234 3456}

eval $unsetScript

test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletable.} {teststatproc} {
    catch {teststatproc delete TclpStat} err2
    set err2
} {"TclpStat": could not be deleteed}

test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} {
    # Delete the 2nd procedure and test that it longer exists but that
    #   the others do actually return a result.
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} {
    list [file exists testAccess2%.fil] \
	    [file exists testAccess1%.fil] \
	    [file exists testAccess3%.fil]
} {1 1 1}

test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletedable.} {
    catch {testaccessproc delete TclpAccess} err2
    set err2
} {"TclpAccess": could not be deleteed}

test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} {
    # Delete the 2nd procedure and test that it longer exists but that
    # the others do actually return a result.







|







130
131
132
133
134
135
136
137
138
139
140
141
142
143
144

test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} {
    list [file exists testAccess2%.fil] \
	    [file exists testAccess1%.fil] \
	    [file exists testAccess3%.fil]
} {1 1 1}

test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletable.} {testaccessproc} {
    catch {testaccessproc delete TclpAccess} err2
    set err2
} {"TclpAccess": could not be deleteed}

test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} {
    # Delete the 2nd procedure and test that it longer exists but that
    # the others do actually return a result.
181
182
183
184
185
186
187




188
189
190
191
192
193
194

    catch {testaccessproc delete TestAccessProc1} err9
    catch {testaccessproc delete TestAccessProc2} err10
    catch {testaccessproc delete TestAccessProc3} err11

    list $err9 $err10 $err11
} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}}





test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
    catch {eval [list file delete -force] [glob *testOpenFileChannel*]}
    catch {file exists testOpenFileChannel1%.fil} err1
    catch {file exists testOpenFileChannel2%.fil} err2
    catch {file exists testOpenFileChannel3%.fil} err3
    catch {file exists __testOpenFileChannel1%__.fil} err4







>
>
>
>







181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198

    catch {testaccessproc delete TestAccessProc1} err9
    catch {testaccessproc delete TestAccessProc2} err10
    catch {testaccessproc delete TestAccessProc3} err11

    list $err9 $err10 $err11
} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}}

# Some of the following tests require a writable current directory
set oldpwd [pwd]
cd [temporaryDirectory]

test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
    catch {eval [list file delete -force] [glob *testOpenFileChannel*]}
    catch {file exists testOpenFileChannel1%.fil} err1
    catch {file exists testOpenFileChannel2%.fil} err2
    catch {file exists testOpenFileChannel3%.fil} err3
    catch {file exists __testOpenFileChannel1%__.fil} err4
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
    file delete __testOpenFileChannel1%__.fil
    file delete __testOpenFileChannel2%__.fil
    file delete __testOpenFileChannel3%__.fil

    set err
} {}

test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletedable.} {testopenfilechannelproc} {
    catch {testopenfilechannelproc delete TclpOpenFileChannel} err2
    set err2
} {"TclpOpenFileChannel": could not be deleteed}

test openfilechannelt-1.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} {
    # Delete the 2nd procedure and test that it longer exists but that
    #   the others do actually return a result.

    testopenfilechannelproc delete TestOpenFileChannelProc2

    close [open __testOpenFileChannel1%__.fil w]
    close [open __testOpenFileChannel3%__.fil w]







|




|







223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
    file delete __testOpenFileChannel1%__.fil
    file delete __testOpenFileChannel2%__.fil
    file delete __testOpenFileChannel3%__.fil

    set err
} {}

test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletable.} {testopenfilechannelproc} {
    catch {testopenfilechannelproc delete TclpOpenFileChannel} err2
    set err2
} {"TclpOpenFileChannel": could not be deleteed}

test ioUtil-3.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} {
    # Delete the 2nd procedure and test that it longer exists but that
    #   the others do actually return a result.

    testopenfilechannelproc delete TestOpenFileChannelProc2

    close [open __testOpenFileChannel1%__.fil w]
    close [open __testOpenFileChannel3%__.fil w]
295
296
297
298
299
300
301


302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
    catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9
    catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10
    catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11

    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}



# cleanup
::tcltest::cleanupTests
return



















>
>



<
<
<
<
<
<
<
<
<
<
<
<
299
300
301
302
303
304
305
306
307
308
309
310












    catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9
    catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10
    catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11

    list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}

cd $oldpwd

# cleanup
::tcltest::cleanupTests
return












Changes to tests/iogt.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
# -*- tcl -*-
# Commands covered:  transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
# 
# RCS: @(#) $Id: iogt.test,v 1.2.14.2 2002/06/10 05:33:16 wolfsuit Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::iogt {

    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint

    testConstraint testchannel [llength [info commands testchannel]]

makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=} dummy


# " capture coloring of quotes

makeFile {} dummyout

makeFile {
#!/usr/local/bin/tclsh
# -*- tcl -*-
# echo server
#
# arguments, options: port to listen on for connections.
#                     delay till echo of first block
#                     delay between blocks












|

|
|












|
>



|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
# -*- tcl -*-
# Commands covered:  transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
# 
# RCS: @(#) $Id: iogt.test,v 1.2.14.3 2002/08/20 20:25:28 das Exp $

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}
namespace eval ::tcl::test::iogt {

    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint

    testConstraint testchannel [llength [info commands testchannel]]

set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]

# " capture coloring of quotes

set path(dummyout) [makeFile {} dummyout]

set path(__echo_srv__.tcl) [makeFile {
#!/usr/local/bin/tclsh
# -*- tcl -*-
# echo server
#
# arguments, options: port to listen on for connections.
#                     delay till echo of first block
#                     delay between blocks
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
}

#fileevent stdin readable {exit ;#cut}

# main
socket -server newconn $port
vwait forever
} __echo_srv__.tcl


########################################################################

proc fevent {fdelay idelay blocks script data} {
    # start and initialize an echo server, prepare data
    # transmission, then hand over to the test script.







|







129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
}

#fileevent stdin readable {exit ;#cut}

# main
socket -server newconn $port
vwait forever
} __echo_srv__.tcl]


########################################################################

proc fevent {fdelay idelay blocks script data} {
    # start and initialize an echo server, prepare data
    # transmission, then hand over to the test script.
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

    array set  a $alist
    array_sget a
}

########################################################################


test iogt-1.1 {stack/unstack} testchannel {
    set fh [open dummy r]
    identity -attach $fh
    testchannel unstack $fh
    close   $fh
} {}

test iogt-1.2 {stack/close} testchannel {
    set fh [open dummy r]
    identity -attach $fh
    close   $fh
} {}

test iogt-1.3 {stack/unstack, configuration, options} testchannel {
    set fh [open dummy r]
    set ca [asort [fconfigure $fh]]
    identity -attach $fh
    set cb [asort [fconfigure $fh]]
    testchannel unstack $fh
    set cc [asort [fconfigure $fh]]
    close $fh

    # With this system none of the buffering, translation and
    # encoding option may change their values with channels
    # stacked upon each other or not.

    # cb == ca == cc

    list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
} {1 1 1}

test iogt-1.4 {stack/unstack, configuration} testchannel {
    set fh [open dummy r]
    set ca [asort [fconfigure $fh]]
    identity -attach $fh
    fconfigure $fh \
	    -buffering   line \
	    -translation cr   \
	    -encoding    shiftjis
    testchannel unstack $fh







<

|






|





|

















|







407
408
409
410
411
412
413

414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

    array set  a $alist
    array_sget a
}

########################################################################


test iogt-1.1 {stack/unstack} testchannel {
    set fh [open $path(dummy) r]
    identity -attach $fh
    testchannel unstack $fh
    close   $fh
} {}

test iogt-1.2 {stack/close} testchannel {
    set fh [open $path(dummy) r]
    identity -attach $fh
    close   $fh
} {}

test iogt-1.3 {stack/unstack, configuration, options} testchannel {
    set fh [open $path(dummy) r]
    set ca [asort [fconfigure $fh]]
    identity -attach $fh
    set cb [asort [fconfigure $fh]]
    testchannel unstack $fh
    set cc [asort [fconfigure $fh]]
    close $fh

    # With this system none of the buffering, translation and
    # encoding option may change their values with channels
    # stacked upon each other or not.

    # cb == ca == cc

    list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
} {1 1 1}

test iogt-1.4 {stack/unstack, configuration} testchannel {
    set fh [open $path(dummy) r]
    set ca [asort [fconfigure $fh]]
    identity -attach $fh
    fconfigure $fh \
	    -buffering   line \
	    -translation cr   \
	    -encoding    shiftjis
    testchannel unstack $fh
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
	    ]

    close $fh
    set res
} {0 line cr shiftjis}

test iogt-2.0 {basic I/O going through transform} testchannel {
    set fin  [open dummy    r]
    set fout [open dummyout w]

    identity -attach $fin
    identity -attach $fout

    fcopy $fin $fout

    close $fin
    close $fout

    set fin  [open dummy    r]
    set fout [open dummyout r]

    set res     [string equal [set in [read $fin]] [set out [read $fout]]]
    lappend res [string length $in] [string length $out]

    close $fin
    close $fout

    set res
} {1 71 71}


test iogt-2.1 {basic I/O, operation trail} {testchannel unixOnly} {
    set fin  [open dummy    r]
    set fout [open dummyout w]

    set ain [list] ; set aout [list]
    audit_ops ain  -attach $fin
    audit_ops aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 5







|
|









|
|












|
|







461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
	    ]

    close $fh
    set res
} {0 line cr shiftjis}

test iogt-2.0 {basic I/O going through transform} testchannel {
    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) w]

    identity -attach $fin
    identity -attach $fout

    fcopy $fin $fout

    close $fin
    close $fout

    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) r]

    set res     [string equal [set in [read $fin]] [set out [read $fout]]]
    lappend res [string length $in] [string length $out]

    close $fin
    close $fout

    set res
} {1 71 71}


test iogt-2.1 {basic I/O, operation trail} {testchannel unixOnly} {
    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) w]

    set ain [list] ; set aout [list]
    audit_ops ain  -attach $fin
    audit_ops aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 5
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
write
write
write
flush/write
delete/write}

test iogt-2.2 {basic I/O, data trail} {testchannel unixOnly} {
    set fin  [open dummy    r]
    set fout [open dummyout w]

    set ain [list] ; set aout [list]
    audit_flow ain  -attach $fin
    audit_flow aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 5







|
|







536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
write
write
write
flush/write
delete/write}

test iogt-2.2 {basic I/O, data trail} {testchannel unixOnly} {
    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) w]

    set ain [list] ; set aout [list]
    audit_flow ain  -attach $fin
    audit_flow aout -attach $fout

    fconfigure $fin  -buffersize 10
    fconfigure $fout -buffersize 5
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
} {
}
flush/write {} {}
delete/write {} *ignored*}


test iogt-2.3 {basic I/O, mixed trail} {testchannel unixOnly} {
    set fin  [open dummy    r]
    set fout [open dummyout w]

    set trail [list]
    audit_flow trail -attach $fin
    audit_flow trail -attach $fout

    fconfigure $fin  -buffersize 20
    fconfigure $fout -buffersize 10







|
|







591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
} {
}
flush/write {} {}
delete/write {} *ignored*}


test iogt-2.3 {basic I/O, mixed trail} {testchannel unixOnly} {
    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) w]

    set trail [list]
    audit_flow trail -attach $fin
    audit_flow trail -attach $fout

    fconfigure $fin  -buffersize 20
    fconfigure $fout -buffersize 10
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
    # I was able to circumvent this by using the echo.tcl server with a big
    # delay, causing the fcopy to underflow immediately.

    proc DoneCopy {n {err {}}} {
	variable copy ; set copy 1
    }

    set fin  [open dummy    r]

    fevent 1000 500 {20 20 20 10 1 1} {
	close $fin

	set          fout [open dummyout w]

	flush $sock ; # now, or fcopy will error us out







|







651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
    # I was able to circumvent this by using the echo.tcl server with a big
    # delay, causing the fcopy to underflow immediately.

    proc DoneCopy {n {err {}}} {
	variable copy ; set copy 1
    }

    set fin  [open $path(dummy) r]

    fevent 1000 500 {20 20 20 10 1 1} {
	close $fin

	set          fout [open dummyout w]

	flush $sock ; # now, or fcopy will error us out
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706

    close $fout

    rename DoneCopy {}

    # Check result of copy.

    set fin  [open dummy    r]
    set fout [open dummyout r]

    set res [string equal [read $fin] [read $fout]]

    close $fin
    close $fout

    list $res $trail
} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}


test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} {
    set fin  [open dummy    r]
    set data [read $fin]
    close $fin

    set trail [list]
    set got   [list]

    proc Done {args} {







|
|











|







679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706

    close $fout

    rename DoneCopy {}

    # Check result of copy.

    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) r]

    set res [string equal [read $fin] [read $fout]]

    close $fin
    close $fout

    list $res $trail
} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}


test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} {
    set fin  [open $path(dummy) r]
    set data [read $fin]
    close $fin

    set trail [list]
    set got   [list]

    proc Done {args} {
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
rblock | delete/read {} {} | {}
flush/write {} {}
delete/write {} *ignored*
delete/read {} *ignored*}  ; # catch unescaped quote "


test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
    set fin  [open dummy    r]
    set fout [open dummyout w]

    set trail [list]

    audit_flow trail -attach $fin
    stopafter_audit d trail 20 -attach   $fin
    audit_flow trail -attach $fout








|
|







823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
rblock | delete/read {} {} | {}
flush/write {} {}
delete/write {} *ignored*
delete/read {} *ignored*}  ; # catch unescaped quote "


test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) w]

    set trail [list]

    audit_flow trail -attach $fin
    stopafter_audit d trail 20 -attach   $fin
    audit_flow trail -attach $fout

902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
}

proc constx {-attach channel} {
    testchannel transform $channel -command [namespace code constX]
}

test iogt-6.0 {Push back} testchannel {
    set f [open dummy r]

    # contents of dummy = "abcdefghi..."
    read $f 3 ; # skip behind "abc"

    constx -attach $f

    # expect to get "xxx" from the transform because
    # of unread "def" input to transform which returns "xxx".
    #
    # Actually the IO layer pre-read the whole file and will
    # read "def" directly from the buffer without bothering
    # to consult the newly stacked transformation. This is
    # wrong.

    set res [read $f 3]
    close $f
    set res
} {xxx}

test iogt-6.1 {Push back and up} {testchannel knownBug} {
    set f [open dummy r]

    # contents of dummy = "abcdefghi..."
    read $f 3 ; # skip behind "abc"

    constx -attach $f
    set res [read $f 3]








|




















|







902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
}

proc constx {-attach channel} {
    testchannel transform $channel -command [namespace code constX]
}

test iogt-6.0 {Push back} testchannel {
    set f [open $path(dummy) r]

    # contents of dummy = "abcdefghi..."
    read $f 3 ; # skip behind "abc"

    constx -attach $f

    # expect to get "xxx" from the transform because
    # of unread "def" input to transform which returns "xxx".
    #
    # Actually the IO layer pre-read the whole file and will
    # read "def" directly from the buffer without bothering
    # to consult the newly stacked transformation. This is
    # wrong.

    set res [read $f 3]
    close $f
    set res
} {xxx}

test iogt-6.1 {Push back and up} {testchannel knownBug} {
    set f [open $path(dummy) r]

    # contents of dummy = "abcdefghi..."
    read $f 3 ; # skip behind "abc"

    constx -attach $f
    set res [read $f 3]

Changes to tests/link.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
# Commands covered:  none
#
# This file contains a collection of tests for Tcl_LinkVar and related
# library procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: link.test,v 1.5.18.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(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













|


|



|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
# Commands covered:  none
#
# This file contains a collection of tests for Tcl_LinkVar and related
# library procedures.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: link.test,v 1.5.18.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::testConstraint testlink \
        [expr {[info commands testlink] != {}}]

foreach i {int real bool string} {
    catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {testlink} {
    testlink delete
Changes to tests/load.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# Commands covered:  load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: load.test,v 1.7.18.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this
# platform.

if {$tcl_platform(platform) == "macintosh"} {
    puts "can't run dynamic library tests on macintosh machines"
    ::tcltest::cleanupTests
    return
}

# Tests require the existence of one of the DLLs in the dltest directory.
set ext [info sharedlibextension]
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]
set dll "[file tail $x]Required"
set ::tcltest::testConstraints($dll) [file readable $x]

# Tests also require that this DLL has not already been loaded.
set loaded "[file tail $x]Loaded"
set alreadyLoaded [info loaded]
set ::tcltest::testConstraints($loaded) \
	[expr {![string match *pkga* $alreadyLoaded]}]

set alreadyTotalLoaded [info loaded]

test load-1.1 {basic errors} [list $dll $loaded] {
    list [catch {load} msg] $msg
} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}












|


|

















|




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# Commands covered:  load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: load.test,v 1.7.18.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Figure out what extension is used for shared libraries on this
# platform.

if {$tcl_platform(platform) == "macintosh"} {
    puts "can't run dynamic library tests on macintosh machines"
    ::tcltest::cleanupTests
    return
}

# Tests require the existence of one of the DLLs in the dltest directory.
set ext [info sharedlibextension]
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]
set dll "[file tail $x]Required"
::tcltest::testConstraint $dll [file readable $x]

# Tests also require that this DLL has not already been loaded.
set loaded "[file tail $x]Loaded"
set alreadyLoaded [info loaded]
::tcltest::testConstraint $loaded \
	[expr {![string match *pkga* $alreadyLoaded]}]

set alreadyTotalLoaded [info loaded]

test load-1.1 {basic errors} [list $dll $loaded] {
    list [catch {load} msg] $msg
} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}
Changes to tests/macFCmd.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19





20
21
22
23
24
25
26
# This file tests the tclfCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: macFCmd.test,v 1.7.18.2 2002/06/10 05:33:16 wolfsuit Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}






catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
    set ::tcltest::testConstraints(fileSharing) 0
    set ::tcltest::testConstraints(notFileSharing) 1
} else {












|






>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# This file tests the tclfCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: macFCmd.test,v 1.7.18.3 2002/08/20 20:25:28 das Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]

catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
    set ::tcltest::testConstraints(fileSharing) 0
    set ::tcltest::testConstraints(notFileSharing) 1
} else {
189
190
191
192
193
194
195

196
197
198
199
200
201
202
203
204
205
206
207
208
209
    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 1} msg] $msg \
	    [file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}

# cleanup

::tcltest::cleanupTests
return



















>


<
<
<
<
<
<
<
<
<
<
<
<
194
195
196
197
198
199
200
201
202
203












    catch {file delete -force foo.dir}
    file mkdir foo.dir
    list [catch {file attributes foo.dir -readonly 1} msg] $msg \
	    [file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}

# cleanup
cd $oldcwd
::tcltest::cleanupTests
return












Changes to tests/main.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17


18
19
20
21
22
23
24
# This file contains a collection of tests for generic/tclMain.c.
#
# RCS: @(#) $Id: main.test,v 1.4.2.2 2002/06/10 05:33:16 wolfsuit Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::main {

    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::interpreter
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile



    # Is [exec] defined?
    testConstraint exec [llength [info commands exec]]

    # Is the Tcltest package loaded?
    #	- that is, the special C-coded testing commands in tclTest.c
    #   - tests use testing commands introduced in Tcltest 8.4


|














>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# This file contains a collection of tests for generic/tclMain.c.
#
# RCS: @(#) $Id: main.test,v 1.4.2.3 2002/08/20 20:25:28 das Exp $

if {[catch {package require tcltest 2.0.2}]} {
    puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
    return
}

namespace eval ::tcl::test::main {

    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::interpreter
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::workingDirectory

    # Is [exec] defined?
    testConstraint exec [llength [info commands exec]]

    # Is the Tcltest package loaded?
    #	- that is, the special C-coded testing commands in tclTest.c
    #   - tests use testing commands introduced in Tcltest 8.4
36
37
38
39
40
41
42

43
44
45
46
47
48
49
		return
	    }
	    # Grrr... Behavior depends on this value.
	    after 1000
	}
    }


    # Tests Tcl_Main-1.*: variable initializations

    test Tcl_Main-1.1 {
	Tcl_Main: startup script - normal
    } -constraints {
	stdio
    } -setup {







>







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
		return
	    }
	    # Grrr... Behavior depends on this value.
	    after 1000
	}
    }

    cd [temporaryDirectory]
    # Tests Tcl_Main-1.*: variable initializations

    test Tcl_Main-1.1 {
	Tcl_Main: startup script - normal
    } -constraints {
	stdio
    } -setup {
1164
1165
1166
1167
1168
1169
1170


1171
1172
1173
1174
1175
1176
		set tcl_interactive 1} >& result
	set f [open result]
	read $f
    } -cleanup {
	close $f
	file delete result
    } -result "1\nfoo\n"



    cleanupTests
}

namespace delete ::tcl::test::main
return







>
>






1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
		set tcl_interactive 1} >& result
	set f [open result]
	read $f
    } -cleanup {
	close $f
	file delete result
    } -result "1\nfoo\n"

    cd [workingDirectory]

    cleanupTests
}

namespace delete ::tcl::test::main
return
Changes to tests/msgcat.test.
1
2
3
4
5
6
7
8
9
10

11
12
13
14



15
16
17
18
19


20
21
22
23
24
25

26
27
28
29
30
31




32
33

34








35
36

37
38









39




40

41

42
43
44









45




46
47
48


49

50
51


52
53
54
55

56
57

58
59
60

61

62
63





64

65
66




67
68
69


70



71
72

73





74
75
76





77
78
79






80
81

82





83
84
85
86
87
88
89
90
91
92
93

94
95
96

97




98
99






100
101
102
103
104
105

106



107
108

109

110
111
112









113
114
115
116
117
118







119
120



121



122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145







146




147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176



177
178
179
180
181


182
183
184
185
186

187
188
189
190


191
192
193
194
195
196
197
198
199
200

201
202
203
204
205
206
207
208
209
210
211
212
213


214

215
216

217
218
219
220
221
222
223
224
225
226
227


228
229


230
231


232
233
234
235
236
237
238


239
240


241
242

243
244
245
246
247
248
249


250
251
252
253
254
255
256
257
258



259



260
261
262

263
264
265


266



267

268
269
270
271
272
273
274
275
276
277
278

279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

300
301

302



303

304
305



306


307
308
309
310
311
312
313

314
315


316
317

318
319
320
321
322
323
324
325
326
327

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349













350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

366
367
368
369
370
371

372
373
374
375

376


377
378
379
380
381

382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398

399
400
401

402
403
404

405





406







407
408
409
410
411
412
413
414
415
416
417
418

419
420
421
422
423
424
425
426
427
428

# Commands covered: ::msgcat::mc ::msgcat::mclocale
#                   ::msgcat::mcpreferences ::msgcat::mcload
#                   ::msgcat::mcset ::msgcat::mcmset ::msgcat::mcunknown
#
# This file contains a collection of tests for the msgcat script library.
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998 Mark Harrison.
# Copyright (c) 1998-1999 by Scriptics Corporation.

#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#



# RCS: @(#) $Id: msgcat.test,v 1.10 2000/07/17 22:25:26 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*


}

if {[catch {package require msgcat 1.0}]} {
    if {[info exist msgcat1]} {
	catch {puts "Cannot load msgcat 1.0 package"}
	return

    } else {
	catch {puts "Running msgcat 1.0 tests in slave interp"}
	set interp [interp create msgcat1]
	$interp eval [list set msgcat1 "running"]
	$interp eval [list source [info script]]
	interp delete $interp




	return
    }

}









set oldlocale [::msgcat::mclocale]


# some tests fail in tne environment variable LANG exists and is not C














if {[info exists env(LANG)] && ($env(LANG) != "C")} {

    set ::tcltest::testConstraints(LANGisC) 0

} else {
    set ::tcltest::testConstraints(LANGisC) 1
}














#
# Test the various permutations of mclocale
# and mcpreferences.


#


test msgcat-1.1 {::msgcat::mclocale default} {LANGisC} {


    ::msgcat::mclocale
} {c}
test msgcat-1.2 {::msgcat::mcpreferences, single element} {LANGisC} {
    ::msgcat::mcpreferences

} {c}
test msgcat-1.3 {::msgcat::mclocale, single element} {

    ::msgcat::mclocale en
} {en}
test msgcat-1.4 {::msgcat::mclocale, single element} {

    ::msgcat::mclocale

} {en}
test msgcat-1.5 {::msgcat::mcpreferences, single element} {





    ::msgcat::mcpreferences

} {en}
test msgcat-1.6 {::msgcat::mclocale, two elements} {




    ::msgcat::mclocale en_US
} {en_us}
test msgcat-1.7 {::msgcat::mclocale, two elements} {


    ::msgcat::mclocale en_US



    ::msgcat::mclocale
} {en_us}

test msgcat-1.8 {::msgcat::mcpreferences, two elements} {





    ::msgcat::mcpreferences
} {en_us en}
test msgcat-1.9 {::msgcat::mclocale, three elements} {





    ::msgcat::mclocale en_US_funky
} {en_us_funky}
test msgcat-1.10 {::msgcat::mclocale, three elements} {






    ::msgcat::mclocale
} {en_us_funky}

test msgcat-1.11 {::msgcat::mcpreferences, three elements} {





    ::msgcat::mcpreferences
} {en_us_funky en_us en}

#
# Test mcset and mc, ensuring that namespace partitioning
# is working.
#

test msgcat-2.1 {::msgcat::mcset, global scope} {
    ::msgcat::mcset  foo_BAR text1 text2
} {text2}

test msgcat-2.2 {::msgcat::mcset, global scope, default} {
    ::msgcat::mcset  foo_BAR text3
} {text3}

test msgcat-2.2 {::msgcat::mcset, namespace overlap} {




    namespace eval bar {::msgcat::mcset  foo_BAR con1 con1bar}
    namespace eval baz {::msgcat::mcset  foo_BAR con1 con1baz}






} {con1baz}
test msgcat-2.3 {::msgcat::mcset, namespace overlap} {
    ::msgcat::mclocale foo_BAR
    namespace eval bar {::msgcat::mc con1}
} {con1bar}
test msgcat-2.4 {::msgcat::mcset, namespace overlap} {

    ::msgcat::mclocale foo_BAR



    namespace eval baz {::msgcat::mc con1}
} {con1baz}

test msgcat-2.5 {::msgcat::mcmset, global scope} {

    ::msgcat::mcmset  foo_BAR {
        src1 trans1
        src2 trans2









    }
    ::msgcat::mc src1
} {trans1}
test msgcat-2.6 {::msgcat::mcmset, namespace overlap} {
    namespace eval bar {::msgcat::mcmset  foo_BAR {con2 con2bar}}
    namespace eval baz {::msgcat::mcmset  foo_BAR {con2 con2baz}}







} {2}
test msgcat-2.7 {::msgcat::mcmset, namespace overlap} {



    ::msgcat::mclocale foo_BAR



    namespace eval baz {::msgcat::mc con2}
} {con2baz}


#
# Test mcset and mc, ensuring that more specific locales
# (e.g. "en_UK") will search less specific locales
# (e.g. "en") for translation strings.
#
# Do this for the 12 permutations of
#     locales: {foo foo_BAR foo_BAR_baz}
#     strings: {ov1 ov2 ov3 ov4}
#     locale foo         defines ov1, ov2, ov3
#     locale foo_BAR     defines      ov2, ov3
#     locale foo_BAR_BAZ defines           ov3
#     (ov4 is defined in none)
# So,
#     ov3 should be resolved in foo, foo_BAR, foo_BAR_baz
#     ov2 should be resolved in foo, foo_BAR
#     ov2 should resolve to foo_BAR in foo_BAR_baz
#     ov1 should be resolved in foo
#     ov1 should resolve to foo in foo_BAR, foo_BAR_baz
#     ov4 should be resolved in none, and call mcunknown
#












test msgcat-3.1 {::msgcat::mcset, overlap} {
    ::msgcat::mcset foo ov1 ov1_foo
    ::msgcat::mcset foo ov2 ov2_foo
    ::msgcat::mcset foo ov3 ov3_foo
    ::msgcat::mcset foo_BAR ov2 ov2_foo_BAR
    ::msgcat::mcset foo_BAR ov3 ov3_foo_BAR
    ::msgcat::mcset foo_BAR_baz ov3 ov3_foo_BAR_baz
} {ov3_foo_BAR_baz}
# top level, locale foo
test msgcat-3.2 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo
    ::msgcat::mc ov1
} {ov1_foo}
test msgcat-3.3 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo
    ::msgcat::mc ov2
} {ov2_foo}
test msgcat-3.4 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo
    ::msgcat::mc ov3
} {ov3_foo}
test msgcat-3.5 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo
    ::msgcat::mc ov4
} {ov4}
# second level, locale foo_BAR
test msgcat-3.6 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo_BAR
    ::msgcat::mc ov1
} {ov1_foo}



test msgcat-3.7 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo_BAR
    ::msgcat::mc ov2
} {ov2_foo_BAR}
test msgcat-3.8 {::msgcat::mcset, overlap} {


    ::msgcat::mclocale foo_BAR
    ::msgcat::mc ov3
} {ov3_foo_BAR}
test msgcat-3.9 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo_BAR

    ::msgcat::mc ov4
} {ov4}
# third level, locale foo_BAR_baz
test msgcat-3.10 {::msgcat::mcset, overlap} {


    ::msgcat::mclocale foo_BAR_baz
    ::msgcat::mc ov1
} {ov1_foo}
test msgcat-3.11 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo_BAR_baz
    ::msgcat::mc ov2
} {ov2_foo_BAR}
test msgcat-3.12 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo_BAR_baz
    ::msgcat::mc ov3

} {ov3_foo_BAR_baz}
test msgcat-3.13 {::msgcat::mcset, overlap} {
    ::msgcat::mclocale foo_BAR_baz
    ::msgcat::mc ov4
} {ov4}

#
# Test mcunknown, first the default operation
# and then with an overridden definition.
#

test msgcat-4.1 {::msgcat::mcunknown, default} {
    ::msgcat::mcset foo unk1 "unknown 1"


} {unknown 1}

test msgcat-4.2 {::msgcat::mcunknown, default} {
    ::msgcat::mclocale foo

    ::msgcat::mc unk1
} {unknown 1}
test msgcat-4.3 {::msgcat::mcunknown, default} {
    ::msgcat::mclocale foo
    ::msgcat::mc unk2
} {unk2}
test msgcat-4.4 {::msgcat::mcunknown, overridden} {
    rename ::msgcat::mcunknown oldproc
    proc ::msgcat::mcunknown {dom s} {
        return "unknown:$dom:$s"
    }


    ::msgcat::mclocale foo
    set result [::msgcat::mc unk1]


    rename ::msgcat::mcunknown {}
    rename oldproc ::msgcat::mcunknown


    set result
} {unknown 1}
test msgcat-4.5 {::msgcat::mcunknown, overridden} {
    rename ::msgcat::mcunknown oldproc
    proc ::msgcat::mcunknown {dom s} {
        return "unknown:$dom:$s"
    }


    ::msgcat::mclocale foo
    set result [::msgcat::mc unk2]


    rename ::msgcat::mcunknown {}
    rename oldproc ::msgcat::mcunknown

    set result
} {unknown:foo:unk2}
test msgcat-4.6 {::msgcat::mcunknown, uplevel context} {
    rename ::msgcat::mcunknown oldproc
    proc ::msgcat::mcunknown {dom s} {
        return "unknown:$dom:$s:[info level]"
    }


    ::msgcat::mclocale foo
    set result [::msgcat::mc unk2]
    rename ::msgcat::mcunknown {}
    rename oldproc ::msgcat::mcunknown
    set result
} {unknown:foo:unk2:1}
    

#



# Test mcload.  Need to set up an environment for



# these tests by creating a temporary directory and
# message files.
#


set locales {en en_US en_US_funky}



catch {file mkdir msgdir}



foreach l $locales {

    set fd [open [string tolower [file join msgdir $l.msg]] w]
    puts $fd "::msgcat::mcset $l abc abc-$l"
    close $fd
}

test msgcat-5.1 {::msgcat::mcload} {
    ::msgcat::mclocale en
    ::msgcat::mcload msgdir
} {1}
test msgcat-5.2 {::msgcat::mcload} {
    ::msgcat::mclocale en_US

    ::msgcat::mcload msgdir
} {2}
test msgcat-5.3 {::msgcat::mcload} {
    ::msgcat::mclocale en_US_funky
    ::msgcat::mcload msgdir
} {3}

# Even though en_US_notexist does not exist,
# en_US and en should be loaded.

test msgcat-5.4 {::msgcat::mcload} {
    ::msgcat::mclocale en_US_notexist
    ::msgcat::mcload msgdir
} {2}
test msgcat-5.5 {::msgcat::mcload} {
    ::msgcat::mclocale no_FI_notexist
    ::msgcat::mcload msgdir
} {0}
test msgcat-5.6 {::msgcat::mcload} {
    ::msgcat::mclocale en
    ::msgcat::mc abc

} {abc-en}
test msgcat-5.7 {::msgcat::mcload} {

    ::msgcat::mclocale en_US



    ::msgcat::mc abc

} {abc-en_US}
test msgcat-5.8 {::msgcat::mcload} {



    ::msgcat::mclocale en_US_funky


    ::msgcat::mc abc
} {abc-en_US_funky}
test msgcat-5.9 {::msgcat::mcload} {
    rename ::msgcat::mcunknown oldproc
    proc ::msgcat::mcunknown {dom s} {
        return "unknown:$dom:$s"
    }

    ::msgcat::mclocale no_FI_notexist
    set result [::msgcat::mc abc]


    rename ::msgcat::mcunknown {}
    rename oldproc ::msgcat::mcunknown

    set result
} {unknown:no_fi_notexist:abc}

# cleanup temp files
foreach l $locales {
    file delete [string tolower [file join msgdir $l.msg]]
}
# Clean out the msg catalogs
file delete msgdir


#
# Test mcset and mc, ensuring that resolution for messages
# proceeds from the current ns to its parent and so on to the 
# global ns.
#
# Do this for the 12 permutations of
#     locales: foo
#     namespaces: ::foo ::foo::bar ::foo::bar::baz
#     strings: {ov1 ov2 ov3 ov4}
#     namespace ::foo            defines ov1, ov2, ov3
#     namespace ::foo::bar       defines      ov2, ov3
#     namespace ::foo::bar::baz  defines           ov3
#
#     ov4 is not defined in any namespace.
#
# So,
#     ov3 should be resolved in ::foo::bar::baz, ::foo::bar, ::foo;
#     ov2 should be resolved in ::foo, ::foo::bar
#     ov1 should be resolved in ::foo
#     ov4 should be resolved in none, and call mcunknown
#














namespace eval ::foo {
    ::msgcat::mcset foo ov1 "ov1_foo"
    ::msgcat::mcset foo ov2 "ov2_foo"
    ::msgcat::mcset foo ov3 "ov3_foo"
}
namespace eval ::foo::bar {
    ::msgcat::mcset foo ov2 "ov2_foo_bar"
    ::msgcat::mcset foo ov3 "ov3_foo_bar"
}    
namespace eval ::foo::bar::baz {
    ::msgcat::mcset foo ov3 "ov3_foo_bar_baz"
}    
::msgcat::mclocale foo

# namespace ::foo
test msgcat-6.1 {::msgcat::mc, namespace resolution} {

    namespace eval ::foo {::msgcat::mc ov1}
} {ov1_foo}
test msgcat-6.2 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo {::msgcat::mc ov2}
} {ov2_foo}
test msgcat-6.3 {::msgcat::mc, namespace resolution} {

    namespace eval ::foo {::msgcat::mc ov3}
} {ov3_foo}
test msgcat-6.4 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo {::msgcat::mc ov4}

} {ov4}


# namespace ::foo::bar
test msgcat-6.5 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar {::msgcat::mc ov1}
} {ov1_foo}
test msgcat-6.6 {::msgcat::mc, namespace resolution} {

    namespace eval ::foo::bar {::msgcat::mc ov2}
} {ov2_foo_bar}
test msgcat-6.7 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar {::msgcat::mc ov3}
} {ov3_foo_bar}
test msgcat-6.8 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar {::msgcat::mc ov4}
} {ov4}
# namespace ::foo
test msgcat-6.9 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar::baz {::msgcat::mc ov1}
} {ov1_foo}
test msgcat-6.10 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar::baz {::msgcat::mc ov2}
} {ov2_foo_bar}
test msgcat-6.11 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar::baz {::msgcat::mc ov3}

} {ov3_foo_bar_baz}
test msgcat-6.12 {::msgcat::mc, namespace resolution} {
    namespace eval ::foo::bar::baz {::msgcat::mc ov4}

} {ov4}

namespace delete ::foo::bar::baz ::foo::bar ::foo







::msgcat::mclocale foo







::msgcat::mcset foo format1 "this is a test"
::msgcat::mcset foo format2 "this is a %s"
::msgcat::mcset foo format3 "this is a %s %s"

test msgcat-7.1 {::msgcat::mc, extra args go through to format} {
    ::msgcat::mc format1 "good test"
} "this is a test"
test msgcat-7.2 {::msgcat::mc, extra args go through to format} {
    ::msgcat::mc format2 "good test"
} "this is a good test"
test msgcat-7.3 {::msgcat::mc, errors from format are propagated} {
    catch {::msgcat::mc format3 "good test"}

} 1
test msgcat-7.4 {::msgcat::mc, extra args are given to unknown} {
    ::msgcat::mc "this is a %s" "good test"
} "this is a good test"

# Reset the locale
::msgcat::mclocale $oldlocale

::tcltest::cleanupTests
return

<
<
<
<
|





>




>
>
>
|

<
|
|
>
>

<
|
<
|
|
>
|
<
<
<
|
|
>
>
>
>
|
|
>
|
>
>
>
>
>
>
>
>
|
<
>
|
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
>
|
>
|
|
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
|
<
<
>
>
|
>

|
>
>
|
|
<
|
>
|
|
>
|
|
|
>
|
>
|
|
>
>
>
>
>
|
>
|
|
>
>
>
>
|
|
|
>
>
|
>
>
>
|
|
>
|
>
>
>
>
>
|
|
|
>
>
>
>
>
|
|
|
>
>
>
>
>
>
|
|
>
|
>
>
>
>
>
|
|

<
|
<
|
<
|
|
|
>
|
|
|
>
|
>
>
>
>
|
|
>
>
>
>
>
>
|
|
|
|
<
|
>
|
>
>
>
|
|
>
|
>
|
|
|
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
>
>
>
>
>
>
>
|
|
>
>
>
|
>
>
>
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
|
>
>
>
>
|
|
|
|
|
|
|
<
|
<
|
<
|
<
|
<
<
<
<
<
<
<
<
<
|
<
<
<
|
|
>
>
>
|
|
|
|
|
>
>
|
<
|
<
|
>
|
|
|
|
>
>
|
<
|
<
|
<
|
<
<
|
>
|
|
|
|
<
|
<
<
<
<
|
<
|
>
>
|
>
|
|
>
|
|
|
<
<
<
|
|
|
|
|
>
>
|
<
>
>
|
|
>
>
|
|
|
|
|
|
|
>
>
|
<
>
>
|
|
>
|
|
|
|
<
<
|
>
>
|
<
|
|
<
<
|
|
<
>
>
>
|
>
>
>
|
|
<
>
|
<

>
>
|
>
>
>
|
>
|
<
<
|

|
|
|
|
<
|
>
|
|
|
<
|
<
|
<
<
<
<
|
<
|
<
|
<
|
<
<
|
>
|
|
>
|
>
>
>
|
>
|
|
>
>
>
|
>
>
|
|
|
|
|
|
|
>
|
<
>
>
|
|
>
|
|

|
|
|
|
<
|

>







|














>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
<
|
|
|
<
|
|
|
<
|
|
<
>
|
|
<
<
|
<
>
|
|
<
|
>
|
>
>
|
|
|
<
|
>
|
|
|
<
|
<
<
|
|
|
|
|
|
|
|
|
|
>
|
<
|
>
|
|
<
>

>
>
>
>
>
|
>
>
>
>
>
>
>
|
|
|
|
<
|
|
<
<
<
<
<
>
|
<
|
|

|
<
|
|

>




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

17
18
19
20
21

22

23
24
25
26



27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84


85
86
87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167

168

169

170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282

283

284

285

286









287



288
289
290
291
292
293
294
295
296
297
298
299
300

301

302
303
304
305
306
307
308
309
310

311

312

313


314
315
316
317
318
319

320




321

322
323
324
325
326
327
328
329
330
331
332



333
334
335
336
337
338
339
340

341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356

357
358
359
360
361
362
363
364
365


366
367
368
369

370
371


372
373

374
375
376
377
378
379
380
381
382

383
384

385
386
387
388
389
390
391
392
393
394


395
396
397
398
399
400

401
402
403
404
405

406

407




408

409

410

411


412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439

440
441
442
443
444
445
446
447
448
449
450
451

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493

494
495
496

497
498
499

500
501

502
503
504


505

506
507
508

509
510
511
512
513
514
515
516

517
518
519
520
521

522


523
524
525
526
527
528
529
530
531
532
533
534

535
536
537
538

539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557

558
559





560
561

562
563
564
565

566
567
568
569




# This file contains a collection of tests for the msgcat package.
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998 Mark Harrison.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
#
# RCS: @(#) $Id: msgcat.test,v 1.10.14.1 2002/08/20 20:25:28 das Exp $


package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}

if {[catch {package require msgcat 1.3}]} {

    puts stderr "Skipping tests in [info script].  No msgcat 1.3 found to test."
    return
}




namespace eval ::msgcat::test {
    namespace import ::msgcat::*
    namespace import ::tcltest::test
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::make*
    namespace import ::tcltest::remove*

    # Tests msgcat-0.*: locale initialization

    proc PowerSet {l} {
	if {[llength $l] == 0} {return [list [list]]}
	set element [lindex $l 0]
	set rest [lrange $l 1 end]
	set result [list]
	foreach x [PowerSet $rest] {
	    lappend result [linsert $x 0 $element]
	    lappend result $x
	}

	return $result
    }

    variable envVars {LC_ALL LC_MESSAGES LANG}
    variable count 0
    variable body
    variable result
    variable setVars
    foreach setVars [PowerSet $envVars] { 
	set result [string tolower [lindex $setVars 0]]
	if {[string length $result] == 0} {
	    set result c
	}
	test msgcat-0.$count {
	    locale initialization from environment variables
	} -setup {
	    variable var
	    foreach var $envVars {
		catch {variable $var $::env($var)}
		catch {unset ::env($var)}
	    }
	    foreach var $setVars {
		set ::env($var) $var
	    }
	    interp create [namespace current]::i
	    i eval [list package ifneeded msgcat [package provide msgcat] \
		    [package ifneeded msgcat [package provide msgcat]]]
	    i eval package require msgcat
	} -cleanup {
	    interp delete [namespace current]::i
	    foreach var $envVars {
		catch {unset ::env($var)}
		catch {set ::env($var) [set [namespace current]::$var]}
	    }
	} -body {i eval msgcat::mclocale} -result $result
	incr count
    }
    catch {unset result}
    


    # Could add tests of initialization from Windows registry here.
    # Use a fake registry package.

    # Tests msgcat-1.*: [mclocale], [mcpreferences]

    test msgcat-1.3 {mclocale set, single element} -setup {
	variable locale [mclocale]
    } -cleanup {
	mclocale $locale
    } -body {

	mclocale en
    } -result en

    test msgcat-1.4 {mclocale get, single element} -setup {
	variable locale [mclocale]
	mclocale en
    } -cleanup {
	mclocale $locale
    } -body {
	mclocale
    } -result en

    test msgcat-1.5 {mcpreferences, single element} -setup {
	variable locale [mclocale]
	mclocale en
    } -cleanup {
	mclocale $locale
    } -body {
	mcpreferences
    } -result en

    test msgcat-1.6 {mclocale set, two elements} -setup {
	variable locale [mclocale]
    } -cleanup {
	mclocale $locale
    } -body {
	mclocale en_US
    } -result en_us

    test msgcat-1.7 {mclocale get, two elements} -setup {
	variable locale [mclocale]
	mclocale en_US
    } -cleanup {
	mclocale $locale
    } -body {
	mclocale
    } -result en_us

    test msgcat-1.8 {mcpreferences, two elements} -setup {
	variable locale [mclocale]
	mclocale en_US
    } -cleanup {
	mclocale $locale
    } -body {
	mcpreferences
    } -result {en_us en}

    test msgcat-1.9 {mclocale set, three elements} -setup {
	variable locale [mclocale]
    } -cleanup {
	mclocale $locale
    } -body {
	mclocale en_US_funky
    } -result en_us_funky

    test msgcat-1.10 {mclocale get, three elements} -setup {
	variable locale [mclocale]
	mclocale en_US_funky
    } -cleanup {
	mclocale $locale
    } -body {
	mclocale
    } -result en_us_funky

    test msgcat-1.11 {mcpreferences, three elements} -setup {
	variable locale [mclocale]
	mclocale en_US_funky
    } -cleanup {
	mclocale $locale
    } -body {
	mcpreferences
    } -result {en_us_funky en_us en}


    # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning



    test msgcat-2.1 {mcset, global scope} {
	namespace eval :: ::msgcat::mcset  foo_BAR text1 text2
    } {text2}

    test msgcat-2.2 {mcset, global scope, default} {
	namespace eval :: ::msgcat::mcset foo_BAR text3
    } {text3}

    test msgcat-2.2 {mcset, namespace overlap} {
	namespace eval baz {::msgcat::mcset  foo_BAR con1 con1baz}
    } {con1baz}

    test msgcat-2.3 {mcset, namespace overlap} -setup {
	namespace eval bar {::msgcat::mcset  foo_BAR con1 con1bar}
	namespace eval baz {::msgcat::mcset  foo_BAR con1 con1baz}
	variable locale [mclocale]
	mclocale foo_BAR
    } -cleanup {
	mclocale $locale
    } -body {
	namespace eval bar {::msgcat::mc con1}
    } -result con1bar

    test msgcat-2.4 {mcset, namespace overlap} -setup {
	namespace eval bar {::msgcat::mcset  foo_BAR con1 con1bar}

	namespace eval baz {::msgcat::mcset  foo_BAR con1 con1baz}
	variable locale [mclocale]
	mclocale foo_BAR
    } -cleanup {
	mclocale $locale
    } -body {
	namespace eval baz {::msgcat::mc con1}
    } -result con1baz

    test msgcat-2.5 {mcmset, global scope} -setup {
	namespace eval :: {
	    ::msgcat::mcmset  foo_BAR {
	        src1 trans1
	        src2 trans2
	    }
	}
	variable locale [mclocale]
	mclocale foo_BAR
    } -cleanup {
	mclocale $locale
    } -body {
	namespace eval :: {
	    ::msgcat::mc src1
	}
    } -result trans1

    test msgcat-2.6 {mcmset, namespace overlap} -setup {
	namespace eval bar {::msgcat::mcmset  foo_BAR {con2 con2bar}}
	namespace eval baz {::msgcat::mcmset  foo_BAR {con2 con2baz}}
	variable locale [mclocale]
	mclocale foo_BAR
    } -cleanup {
	mclocale $locale
    } -body {
	namespace eval bar {::msgcat::mc con2}
    } -result con2bar

    test msgcat-2.7 {mcmset, namespace overlap} -setup {
	namespace eval bar {::msgcat::mcmset  foo_BAR {con2 con2bar}}
	namespace eval baz {::msgcat::mcmset  foo_BAR {con2 con2baz}}
	variable locale [mclocale]
	mclocale foo_BAR
    } -cleanup {
	mclocale $locale
    } -body {
	namespace eval baz {::msgcat::mc con2}
    } -result con2baz

    # Tests msgcat-3.*: [mcset], [mc], catalog "inheritance"
    #
    # Test mcset and mc, ensuring that more specific locales
    # (e.g. en_UK) will search less specific locales
    # (e.g. en) for translation strings.
    #
    # Do this for the 12 permutations of
    #     locales: {foo foo_BAR foo_BAR_baz}
    #     strings: {ov1 ov2 ov3 ov4}
    #     locale foo         defines ov1, ov2, ov3
    #     locale foo_BAR     defines      ov2, ov3
    #     locale foo_BAR_BAZ defines           ov3
    #     (ov4 is defined in none)
    # So,
    #     ov3 should be resolved in foo, foo_BAR, foo_BAR_baz
    #     ov2 should be resolved in foo, foo_BAR
    #     ov2 should resolve to foo_BAR in foo_BAR_baz
    #     ov1 should be resolved in foo
    #     ov1 should resolve to foo in foo_BAR, foo_BAR_baz
    #     ov4 should be resolved in none, and call mcunknown
    #
    variable count 2
    variable result
    array set result {
	foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
	foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR foo_BAR,ov3 ov3_foo_BAR
	foo_BAR,ov4 ov4 foo_BAR_baz,ov1 ov1_foo foo_BAR_baz,ov2 ov2_foo_BAR
	foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4
    }
    variable loc
    variable string
    foreach loc {foo foo_BAR foo_BAR_baz} {
	foreach string {ov1 ov2 ov3 ov4} {
	    test msgcat-3.$count {mcset, overlap} -setup {
		mcset foo ov1 ov1_foo
		mcset foo ov2 ov2_foo
		mcset foo ov3 ov3_foo
		mcset foo_BAR ov2 ov2_foo_BAR
		mcset foo_BAR ov3 ov3_foo_BAR
		mcset foo_BAR_baz ov3 ov3_foo_BAR_baz

		variable locale [mclocale]

		mclocale $loc

	    } -cleanup {

		mclocale $locale









	    } -body {



		mc $string
	    } -result $result($loc,$string)
	    incr count
	}
    }
    catch {unset result}

    # Tests msgcat-4.*: [mcunknown]

    test msgcat-4.2 {mcunknown, default} -setup {
	mcset foo unk1 "unknown 1"
	variable locale [mclocale]
	mclocale foo

    } -cleanup {

	mclocale $locale
    } -body {
	mc unk1
    } -result {unknown 1}

    test msgcat-4.3 {mcunknown, default} -setup {
	mcset foo unk1 "unknown 1"
	variable locale [mclocale]
	mclocale foo

    } -cleanup {

	mclocale $locale

    } -body {


	mc unk2
    } -result unk2

    test msgcat-4.4 {mcunknown, overridden} -setup {
	rename ::msgcat::mcunknown SavedMcunknown
	proc ::msgcat::mcunknown {dom s} {

            return unknown:$dom:$s




	}

	mcset foo unk1 "unknown 1"
	variable locale [mclocale]
	mclocale foo
    } -cleanup {
	mclocale $locale
	rename ::msgcat::mcunknown {}
	rename SavedMcunknown ::msgcat::mcunknown
    } -body {
	mc unk1
    } -result {unknown 1}




    test msgcat-4.5 {mcunknown, overridden} -setup {
	rename ::msgcat::mcunknown SavedMcunknown
	proc ::msgcat::mcunknown {dom s} {
            return unknown:$dom:$s
	}
	mcset foo unk1 "unknown 1"
	variable locale [mclocale]
	mclocale foo

    } -cleanup {
	mclocale $locale
	rename ::msgcat::mcunknown {}
	rename SavedMcunknown ::msgcat::mcunknown
    } -body {
	mc unk2
    } -result {unknown:foo:unk2}

    test msgcat-4.6 {mcunknown, uplevel context} -setup {
	rename ::msgcat::mcunknown SavedMcunknown
	proc ::msgcat::mcunknown {dom s} {
            return "unknown:$dom:$s:[expr {[info level] - 1}]"
	}
	mcset foo unk1 "unknown 1"
	variable locale [mclocale]
	mclocale foo

    } -cleanup {
	mclocale $locale
	rename ::msgcat::mcunknown {}
	rename SavedMcunknown ::msgcat::mcunknown
    } -body {
	mc unk2
    } -result unknown:foo:unk2:[info level]

    # Tests msgcat-5.*: [mcload]



    variable locales {foo foo_BAR foo_BAR_baz}
    makeDirectory msgdir
    foreach loc $locales {

	makeFile "::msgcat::mcset $loc abc abc-$loc" \
		[string tolower [file join msgdir $loc.msg]]


    }
    variable count 1

    foreach loc {foo foo_BAR foo_BAR_baz} {
	test msgcat-5.$count {mcload} -setup {
	    variable locale [mclocale]
	    mclocale $loc
	} -cleanup {
	    mclocale $locale
	} -body {
	    mcload [file join [temporaryDirectory] msgdir]
	} -result $count

	incr count
    }


    # Even though foo_BAR_notexist does not exist,
    # foo_BAR and foo should be loaded.
	test msgcat-5.4 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale foo_BAR_notexist
	} -cleanup {
	    mclocale $locale
	} -body {
	    mcload [file join [temporaryDirectory] msgdir]


	} -result 2

	test msgcat-5.5 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale no_FI_notexist
	} -cleanup {

	    mclocale $locale
	} -body {
	    mcload [file join [temporaryDirectory] msgdir]
	} -result 0


	test msgcat-5.6 {mcload} -setup {

	    variable locale [mclocale]




	    mclocale foo

	} -cleanup {

	    mclocale $locale

	} -body {


	    mc abc
	} -result abc-foo

	test msgcat-5.7 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale foo_BAR
	} -cleanup {
	    mclocale $locale
	} -body {
	    mc abc
	} -result abc-foo_BAR

	test msgcat-5.8 {mcload} -setup {
	    variable locale [mclocale]
	    mclocale foo_BAR_baz
	} -cleanup {
	    mclocale $locale
	} -body {
	    mc abc
	} -result abc-foo_BAR_baz

	test msgcat-5.9 {mcload} -setup {
	    rename ::msgcat::mcunknown SavedMcunknown
	    proc ::msgcat::mcunknown {dom s} {
		return unknown:$dom:$s
	    }
	    variable locale [mclocale]
	    mclocale no_FI_notexist

	} -cleanup {
	    mclocale $locale
	    rename ::msgcat::mcunknown {}
	    rename SavedMcunknown ::msgcat::mcunknown
	} -body {
	    mc abc
	} -result unknown:no_fi_notexist:abc


    foreach loc $locales {
	removeFile [string tolower [file join msgdir $loc.msg]]
    }

    removeDirectory msgdir

    # Tests msgcat-6.*: [mcset], [mc] namespace inheritance
#
# Test mcset and mc, ensuring that resolution for messages
# proceeds from the current ns to its parent and so on to the 
# global ns.
#
# Do this for the 12 permutations of
#     locales: foo
#     namespaces: foo foo::bar foo::bar::baz
#     strings: {ov1 ov2 ov3 ov4}
#     namespace ::foo            defines ov1, ov2, ov3
#     namespace ::foo::bar       defines      ov2, ov3
#     namespace ::foo::bar::baz  defines           ov3
#
#     ov4 is not defined in any namespace.
#
# So,
#     ov3 should be resolved in ::foo::bar::baz, ::foo::bar, ::foo;
#     ov2 should be resolved in ::foo, ::foo::bar
#     ov1 should be resolved in ::foo
#     ov4 should be resolved in none, and call mcunknown
#

    variable result
    array set result {
	foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
	foo::bar,ov1 ov1_foo foo::bar,ov2 ov2_foo_bar
	foo::bar,ov3 ov3_foo_bar foo::bar,ov4 ov4 foo::bar::baz,ov1 ov1_foo
	foo::bar::baz,ov2 ov2_foo_bar foo::bar::baz,ov3 ov3_foo_bar_baz
	foo::bar::baz,ov4 ov4
    }
    variable count 1
    variable ns
    foreach ns {foo foo::bar foo::bar::baz} {
	foreach string {ov1 ov2 ov3 ov4} {
	    test msgcat-6.$count {mcset, overlap} -setup {
		namespace eval foo {
		    ::msgcat::mcset foo ov1 ov1_foo
		    ::msgcat::mcset foo ov2 ov2_foo
		    ::msgcat::mcset foo ov3 ov3_foo

		    namespace eval bar {
			::msgcat::mcset foo ov2 ov2_foo_bar
			::msgcat::mcset foo ov3 ov3_foo_bar

			namespace eval baz {
			    ::msgcat::mcset foo ov3 "ov3_foo_bar_baz"
			}

		    }
		    

		}
		variable locale [mclocale]
		mclocale foo


	    } -cleanup {

		mclocale $locale
		namespace delete foo
	    } -body {

		namespace eval $ns [list ::msgcat::mc $string]
	    } -result $result($ns,$string)
	    incr count
	}
    }

    # Tests msgcat-7.*: [mc] extra args processed by [format]


    test msgcat-7.1 {mc extra args go through to format} -setup {
	mcset foo format1 "this is a test"
	mcset foo format2 "this is a %s"
	mcset foo format3 "this is a %s %s"
	variable locale [mclocale]

	mclocale foo


    } -cleanup {
	mclocale $locale
    } -body {
	mc format1 "good test"
    } -result "this is a test"

    test msgcat-7.2 {mc extra args go through to format} -setup {
	mcset foo format1 "this is a test"
	mcset foo format2 "this is a %s"
	mcset foo format3 "this is a %s %s"
	variable locale [mclocale]
	mclocale foo

    } -cleanup {
	mclocale $locale
    } -body {
	mc format2 "good test"

    } -result "this is a good test"

    test msgcat-7.3 {mc errors from format are propagated} -setup {
	mcset foo format1 "this is a test"
	mcset foo format2 "this is a %s"
	mcset foo format3 "this is a %s %s"
	variable locale [mclocale]
	mclocale foo
    } -cleanup {
	mclocale $locale
    } -body {
	catch {mc format3 "good test"}
    } -result 1

    test msgcat-7.4 {mc, extra args are given to unknown} -setup {
	mcset foo format1 "this is a test"
	mcset foo format2 "this is a %s"
	mcset foo format3 "this is a %s %s"
	variable locale [mclocale]

	mclocale foo
    } -cleanup {





	mclocale $locale
    } -body {

	mc "this is a %s" "good test"
    } -result "this is a good test"

    cleanupTests

}
namespace delete ::msgcat::test
return

Changes to tests/namespace.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.17.4.1 2002/02/05 02:22:04 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {













|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.17.4.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}

test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
    }
    ns::a 1
    set res [ns::a 2]
    namespace delete ns
    set res
} {New proc is called}

test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownbug} {
    set res {}
    namespace eval ns {
	variable b 0
    }

    proc ns::a {i} {
	variable b







|







1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
    }
    ns::a 1
    set res [ns::a 2]
    namespace delete ns
    set res
} {New proc is called}

test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownBug} {
    set res {}
    namespace eval ns {
	variable b 0
    }

    proc ns::a {i} {
	variable b
Changes to tests/parseExpr.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains a collection of tests for the procedures in the
# file tclParseExpr.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseExpr.test,v 1.5.18.1 2002/02/05 02:22:04 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Note that the Tcl expression parser (tclParseExpr.c) does not check










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# This file contains a collection of tests for the procedures in the
# file tclParseExpr.c.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseExpr.test,v 1.5.18.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Note that the Tcl expression parser (tclParseExpr.c) does not check
505
506
507
508
509
510
511

512
513
514

515
516
517
518
519
520
521
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} {
    testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} {
    list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}

test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} {
    list [catch {testexprparser {0999} -1} msg] $msg
} {1 {"0999" is an invalid octal number}}

test parseExpr-16.7 {GetLexeme procedure, double lexeme} {
    testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
test parseExpr-16.8 {GetLexeme procedure, double lexeme} {
    testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
test parseExpr-16.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {







>
|
|
|
>







505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} {
    testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} {
    list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}

test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -body {
    testexprparser {0999} -1
} -returnCodes error -match glob -result {*invalid octal number*}

test parseExpr-16.7 {GetLexeme procedure, double lexeme} {
    testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
test parseExpr-16.8 {GetLexeme procedure, double lexeme} {
    testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
test parseExpr-16.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
Changes to tests/parseOld.test.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24



25
26
27
28
29
30
31
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseOld.test,v 1.10 2001/08/02 01:20:05 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testwordend \
	[string equal "testwordend" [info commands testwordend]]




proc fourArgs {a b c d} {
    global arg1 arg2 arg3 arg4
    set arg1 $a
    set arg2 $b
    set arg3 $c
    set arg4 $d







|








>
>
>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseOld.test,v 1.10.8.1 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

tcltest::testConstraint testwordend \
	[string equal "testwordend" [info commands testwordend]]

# Save the argv value for restoration later
set savedArgv $argv

proc fourArgs {a b c d} {
    global arg1 arg2 arg3 arg4
    set arg1 $a
    set arg2 $b
    set arg3 $c
    set arg4 $d
532
533
534
535
536
537
538

539
540
541
542
543
544
545
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup

::tcltest::cleanupTests
return












>







535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
    info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
    info complete "xyz \[abc"
} {0}

# cleanup
set argv $savedArgv
::tcltest::cleanupTests
return





Changes to tests/pid.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
# Commands covered:  pid
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pid.test,v 1.6 2000/04/10 17:19:03 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
    puts "pid is not implemented for this machine"
    ::tcltest::cleanupTests
    return
}

catch {removeFile test1}


test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {unixOrPc unixExecs} {
    set f [open {| echo foo | cat >test1} w]
    set pids [pid $f]
    close $f
    catch {removeFile test1}
    list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
       [regexp {^[0-9]+$} [lindex $pids 1]] \
       [expr {[lindex $pids 0] == [lindex $pids 1]}]
} {2 1 1 0}
test pid-1.3 {pid command} {
    set f [open test1 w]
    set pids [pid $f]
    close $f
    set pids
} {}
test pid-1.4 {pid command} {
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}













|















>





|








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
# Commands covered:  pid
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pid.test,v 1.6.18.1 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
    puts "pid is not implemented for this machine"
    ::tcltest::cleanupTests
    return
}

catch {removeFile test1}
set path(test1) [makeFile {} test1]

test pid-1.1 {pid command} {
    regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {unixOrPc unixExecs} {
    set f [open [format {| echo foo | cat >%s} $path(test1)] w]
    set pids [pid $f]
    close $f
    catch {removeFile test1}
    list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
       [regexp {^[0-9]+$} [lindex $pids 1]] \
       [expr {[lindex $pids 0] == [lindex $pids 1]}]
} {2 1 1 0}
test pid-1.3 {pid command} {
    set f [open $path(test1) w]
    set pids [pid $f]
    close $f
    set pids
} {}
test pid-1.4 {pid command} {
    list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
Deleted tests/pkg/circ1.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
# circ1.tcl --
#
#  Test package for pkg_mkIndex. This package requires circ2, and circ2
#  requires circ3, which in turn requires circ1.
#  In case of cirularities, pkg_mkIndex should give up when it gets stuck.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: circ1.tcl,v 1.1 1998/10/17 00:21:39 escoffon Exp $

package require circ2 1.0

package provide circ1 1.0

namespace eval circ1 {
    namespace export c1-1 c1-2 c1-3 c1-4
}

proc circ1::c1-1 { num } {
    return [circ2::c2-1 $num]
}

proc circ1::c1-2 { num } {
    return [circ2::c2-2 $num]
}

proc circ1::c1-3 {} {
    return 10
}

proc circ1::c1-4 {} {
    return 20
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































Deleted tests/pkg/circ2.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
# circ2.tcl --
#
#  Test package for pkg_mkIndex. This package is required by circ1, and
#  requires circ3. Circ3, in turn, requires circ1 to give us a circularity.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: circ2.tcl,v 1.1 1998/10/17 00:21:39 escoffon Exp $

package require circ3 1.0

package provide circ2 1.0

namespace eval circ2 {
    namespace export c2-1 c2-2
}

proc circ2::c2-1 { num } {
    return [expr $num * [circ3::c3-1]]
}

proc circ2::c2-2 { num } {
    return [expr $num * [circ3::c3-2]]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted tests/pkg/circ3.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
# circ3.tcl --
#
#  Test package for pkg_mkIndex. This package is required by circ2, and in
#  turn requires circ1. This closes the circularity.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: circ3.tcl,v 1.1 1998/10/17 00:21:40 escoffon Exp $

package require circ1 1.0

package provide circ3 1.0

namespace eval circ3 {
    namespace export c3-1 c3-4
}

proc circ3::c3-1 {} {
    return [circ1::c1-3]
}

proc circ3::c3-2 {} {
    return [circ1::c1-4]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted tests/pkg/global.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# global.tcl --
#
#  Test package for pkg_mkIndex.
#  Contains global symbols, used to check that they don't have a leading ::
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: global.tcl,v 1.1 1998/10/17 00:21:40 escoffon Exp $

package provide global 1.0

proc global_lower { stg } {
    return [string tolower $stg]
}

proc global_upper { stg } {
    return [string toupper $stg]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted tests/pkg/import.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
package provide fubar 1.0
    
namespace eval ::fubar:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}

proc ::fubar::foo {bar} {
    puts "$bar"
    return true
}

namespace import ::fubar::foo

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted tests/pkg/magicchar.tcl.
1
2
3
4
5
6
set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo"
set bracket1 "this contains an unescaped bracket [NoSuchProc]"
set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]"
proc testProc {} {}
<
<
<
<
<
<












Deleted tests/pkg/magicchar2.tcl.
1
proc {[magic mojo proc]} {} {}
<


Deleted tests/pkg/pkg1.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
# pkg1.tcl --
#
#  Test package for pkg_mkIndex. This package requires pkg3, but it does
#  not use any of pkg3's procs in the code that is executed by the file
#  (i.e. references to pkg3's procs are in the proc bodies only).
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: pkg1.tcl,v 1.1 1998/10/17 00:21:40 escoffon Exp $

package require pkg3 1.0

package provide pkg1 1.0

namespace eval pkg1 {
    namespace export p1-1 p1-2
}

proc pkg1::p1-1 { num } {
    return [pkg3::p3-1 $num]
}

proc pkg1::p1-2 { num } {
    return [pkg3::p3-2 $num]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































Deleted tests/pkg/pkg2_a.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# pkg2_a.tcl --
#
#  Test package for pkg_mkIndex. This package is required by pkg1.
#  This package is split into two files, to test packages that are split
#  over multiple files.
#
# Copyright (c) 2998 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# SCCS: %Z% %M% %I% %E% %U%

package provide pkg2 1.0

namespace eval pkg2 {
    namespace export p2-1
}

proc pkg2::p2-1 { num } {
    return [expr $num * 2]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































Deleted tests/pkg/pkg2_b.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# pkg2_b.tcl --
#
#  Test package for pkg_mkIndex. This package is required by pkg1.
#  This package is split into two files, to test packages that are split
#  over multiple files.
#
# Copyright (c) 2998 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# SCCS: %Z% %M% %I% %E% %U%

package provide pkg2 1.0

namespace eval pkg2 {
    namespace export p2-2
}

proc pkg2::p2-2 { num } {
    return [expr $num * 3]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































Deleted tests/pkg/pkg3.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# pkg3.tcl --
#
#  Test package for pkg_mkIndex.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: pkg3.tcl,v 1.1 1998/10/17 00:21:42 escoffon Exp $

package provide pkg3 1.0

namespace eval pkg3 {
    namespace export p3-1 p3-2
}

proc pkg3::p3-1 { num } {
    return {[expr $num * 2]}
}

proc pkg3::p3-2 { num } {
    return {[expr $num * 3]}
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































Deleted tests/pkg/pkg4.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
# pkg4.tcl --
#
#  Test package for pkg_mkIndex. This package requires pkg3, and it calls
#  a pkg3 proc in the code that is executed by the file
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: pkg4.tcl,v 1.1 1998/10/17 00:21:42 escoffon Exp $

package require pkg3 1.0

package provide pkg4 1.0

namespace eval pkg4 {
    namespace export p4-1 p4-2
    variable m2 [pkg3::p3-1 10]
}

proc pkg4::p4-1 { num } {
    variable m2
    return [expr {$m2 * $num}]
}

proc pkg4::p4-2 { num } {
    return [pkg3::p3-2 $num]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































Deleted tests/pkg/pkg5.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
# pkg5.tcl --
#
#  Test package for pkg_mkIndex. This package requires pkg2, and it calls
#  a pkg2 proc in the code that is executed by the file.
#  Pkg2 is a split package.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: pkg5.tcl,v 1.1 1998/10/17 00:21:42 escoffon Exp $

package require pkg2 1.0

package provide pkg5 1.0

namespace eval pkg5 {
    namespace export p5-1 p5-2
    variable m2 [pkg2::p2-1 10]
    variable m3 [pkg2::p2-2 10]
}

proc pkg5::p5-1 { num } {
    variable m2
    return [expr {$m2 * $num}]
}

proc pkg5::p5-2 { num } {
    variable m2
    return [expr {$m2 * $num}]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































Deleted tests/pkg/pkga.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# pkga.tcl --
#
#  Test package for pkg_mkIndex. This package provides Pkga,
#  which is also provided by a DLL.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: pkga.tcl,v 1.1 1998/12/04 06:28:11 welch Exp $

package provide Pkga 1.0

proc pkga_neq { x } {
    return [expr {! [pkgq_eq $x]}]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























Deleted tests/pkg/samename.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
package provide football 1.0
    
namespace eval ::pro:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}
namespace eval ::college:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}

proc ::pro::team {} {
    puts "go packers!"
    return true
}

proc ::college::team {} {
    puts "go badgers!"
    return true
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted tests/pkg/simple.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# simple.tcl --
#
#  Test package for pkg_mkIndex. This is a simple package, just to check
#  basic functionality.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: simple.tcl,v 1.1 1998/10/17 00:21:43 escoffon Exp $

package provide simple 1.0

namespace eval simple {
    namespace export lower upper
}

proc simple::lower { stg } {
    return [string tolower $stg]
}

proc simple::upper { stg } {
    return [string toupper $stg]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Deleted tests/pkg/spacename.tcl.
1
2
3
package provide spacename 1.0
proc {a b} {} {}
proc {c d} {} {}
<
<
<






Deleted tests/pkg/std.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
# std.tcl --
#
#  Test package for pkg_mkIndex.
#  Does a package require of direct1, whose pkgIndex.tcl entry (in pkg1)
#  should be a -direct entry.
#  This tests that pkg_mkIndex can handle code that is sourced in pkgIndex.tcl
#  files.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: std.tcl,v 1.1 1998/10/17 00:21:43 escoffon Exp $

package require direct1

package provide std 1.0

namespace eval std {
    namespace export p1 p2
}

proc std::p1 { stg } {
    return [string tolower $stg]
}

proc std::p2 { stg } {
    return [string toupper $stg]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































Deleted tests/pkg1/direct1.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# std.tcl --
#
#  Test support package for pkg_mkIndex.
#  This is referenced by pkgIndex.tcl as a -direct script.
#
# Copyright (c) 1998 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: direct1.tcl,v 1.1 1998/10/17 00:21:44 escoffon Exp $

package provide direct1 1.0

namespace eval direct1 {
    namespace export pd1 pd2
}

proc direct1::pd1 { stg } {
    return [string tolower $stg]
}

proc direct1::pd2 { stg } {
    return [string toupper $stg]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Deleted tests/pkg1/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.

package ifneeded direct1 1.0 [list source [file join $dir direct1.tcl]]
<
<
<
<
<
<
<
<
<
<
<






















Changes to tests/pkgMkIndex.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
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.18.14.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set origDir [pwd]
cd $::tcltest::testsDirectory

set fullPkgPath [file join $::tcltest::testsDirectory pkg]

# Add the pkg1 directory to auto_path, so that its packages can be found.
# packages in pkg1 are used to test indexing of packages in pkg.
# Make sure that the path to pkg1 is absolute.

lappend auto_path [file join $::tcltest::testsDirectory pkg1]

namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#










|


|



<
<
<
|

<
<
<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17



18
19





20
21
22
23
24
25
26
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.18.14.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}




set fullPkgPath [makeDirectory pkg]







namespace eval pkgtest {
    # Namespace for procs we can discard
}

# pkgtest::parseArgs --
#
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
proc pkgtest::createIndex { args } {
    set parsed [eval parseArgs $args]
    set options [lindex $parsed 0]
    set dirPath [lindex $parsed 1]
    set patternList [lindex $parsed 2]

    file mkdir $dirPath
 
    if {[catch {
	file delete [file join $dirPath pkgIndex.tcl]
	eval pkg_mkIndex $options [list $dirPath] $patternList
    } err]} {
	return [list 1 $err]
    }








|







150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
proc pkgtest::createIndex { args } {
    set parsed [eval parseArgs $args]
    set options [lindex $parsed 0]
    set dirPath [lindex $parsed 1]
    set patternList [lindex $parsed 2]

    file mkdir $dirPath

    if {[catch {
	file delete [file join $dirPath pkgIndex.tcl]
	eval pkg_mkIndex $options [list $dirPath] $patternList
    } err]} {
	return [list 1 $err]
    }

233
234
235
236
237
238
239
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
# Results:
#  Returns a two element list:
#    0: 1 if the procedure encountered an error, 0 otherwise.
#    1: if no error, this is the parsed generated index file, in the format
#	returned by pkgtest::parseIndex.
#	If error, this is the error result.

proc pkgtest::runIndex { args } {
    set rv [eval createIndex $args]
    if {[lindex $rv 0] == 0} {
	set parsed [eval parseArgs $args]
	set dirPath [lindex $parsed 1]
	set idxFile [file join $dirPath pkgIndex.tcl]

	if {[catch {
	    set result [list 0 [makePkgList [parseIndex $idxFile]]]
	} err]} {
	    set result [list 1 $err]
	} 
	file delete $idxFile
    } else {
	set result $rv
    }

    return $result
}





# If there is no match to the patterns, make sure the directory hasn't
# changed on us

test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} {
    list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd]
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]















test pkgMkIndex-2.1 {simple package} {
    pkgtest::runIndex -lazy $fullPkgPath simple.tcl
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}

test pkgMkIndex-2.2 {simple package - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"

test pkgMkIndex-2.3 {simple package - direct loading is default} {
    pkgtest::runIndex $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"














test pkgMkIndex-3.1 {simple package with global symbols} {
    pkgtest::runIndex -lazy $fullPkgPath global.tcl
} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}





























test pkgMkIndex-4.1 {split package} {
    pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}

test pkgMkIndex-4.2 {split package - direct loading} {
    pkgtest::runIndex -direct $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
[list source [file join $fullPkgPath pkg2_b.tcl]]}}}"



# This will fail, with "direct1" procedures in the list of procedures



# provided by std.











# It may also fail, if tclblend is in the auto_path, with an additional



# command "loadJava" which comes from the tclblend pkgIndex.tcl file.











# Both failures are caused by Tcl code executed in pkgIndex.tcl.

test pkgMkIndex-5.1 {requires -direct package} {
    pkgtest::runIndex -lazy $fullPkgPath std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}




































test pkgMkIndex-6.1 {pkg1 requires pkg3} {
    pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}

test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath pkg1.tcl pkg3.tcl
} "0 {{pkg1:1.0 {[list source [file join $fullPkgPath pkg1.tcl]]}} {pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}}}"





















test pkgMkIndex-7.1 {pkg4 uses pkg3} {
    pkgtest::runIndex -lazy $fullPkgPath pkg4.tcl pkg3.tcl
} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}}

test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath pkg4.tcl pkg3.tcl
} "0 {{pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}} {pkg4:1.0 {[list source [file join $fullPkgPath pkg4.tcl]]}}}"

























test pkgMkIndex-8.1 {pkg5 uses pkg2} {
    pkgtest::runIndex -lazy $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}}

test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
[list source [file join $fullPkgPath pkg2_b.tcl]]}} {pkg5:1.0 {[list source [file join $fullPkgPath pkg5.tcl]]}}}"




























































test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex -lazy $fullPkgPath circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}





# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join [file dirname [info nameofexecutable]] dltest \
	pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
set ::tcltest::testConstraints($dll) [file exists $x]




test pkgMkIndex-10.1 {package in DLL and script} $dll {




    file copy -force $x $fullPkgPath









    pkgtest::runIndex -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
test pkgMkIndex-10.2 {package in DLL hidden by -load} $dll {









    pkgtest::runIndex -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
} {0 {}}






# Tolerate "namespace import" at the global scope
















test pkgMkIndex-11.1 {conflicting namespace imports} {
    pkgtest::runIndex -lazy $fullPkgPath import.tcl
} {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}}



# Verify that the auto load list generated is correct even when there
# is a proc name conflict between two namespaces (ie, ::foo::baz and
# ::bar::baz)

























test pkgMkIndex-12.1 {same name procs in different namespace} {
    pkgtest::runIndex -lazy $fullPkgPath samename.tcl
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}



# Proc names with embedded spaces are properly listed (ie, correct number of
# braces) in result






test pkgMkIndex-13.1 {proc names with embedded spaces} {
    pkgtest::runIndex -lazy $fullPkgPath spacename.tcl
} {0 {{spacename:1.0 {tclPkgSetup {spacename.tcl source {{a b} {c d}}}}}}}



# Test the pkg_compareExtension helper function
test pkgMkIndex-14.1 {pkg_compareExtension} {unixOnly} {
    pkg_compareExtension foo.so .so
} 1
test pkgMkIndex-14.2 {pkg_compareExtension} {unixOnly} {
    pkg_compareExtension foo.so.bar .so







|
<

















>
>
>
>








>
>
>
>
>
>
>
>
>
>
>
>
>
>












>
>
>
>
>
>
>
>
>
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




>
>
>
>





|

>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|

|
>
>
>
>
>
>
>
>
>
|

>
>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>





>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



>
>



>
>
>
>
>
>



>
>







225
226
227
228
229
230
231
232

233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
# Results:
#  Returns a two element list:
#    0: 1 if the procedure encountered an error, 0 otherwise.
#    1: if no error, this is the parsed generated index file, in the format
#	returned by pkgtest::parseIndex.
#	If error, this is the error result.

proc pkgtest::runCreatedIndex {rv args} {

    if {[lindex $rv 0] == 0} {
	set parsed [eval parseArgs $args]
	set dirPath [lindex $parsed 1]
	set idxFile [file join $dirPath pkgIndex.tcl]

	if {[catch {
	    set result [list 0 [makePkgList [parseIndex $idxFile]]]
	} err]} {
	    set result [list 1 $err]
	} 
	file delete $idxFile
    } else {
	set result $rv
    }

    return $result
}
proc pkgtest::runIndex { args } {
    set rv [eval createIndex $args]
    return [eval [list runCreatedIndex $rv] $args]
}

# If there is no match to the patterns, make sure the directory hasn't
# changed on us

test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} {
    list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd]
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]

makeFile {
#  This is a simple package, just to check basic functionality.
package provide simple 1.0
namespace eval simple {
    namespace export lower upper
}
proc simple::lower { stg } {
    return [string tolower $stg]
}
proc simple::upper { stg } {
    return [string toupper $stg]
}
} [file join pkg simple.tcl]

test pkgMkIndex-2.1 {simple package} {
    pkgtest::runIndex -lazy $fullPkgPath simple.tcl
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}

test pkgMkIndex-2.2 {simple package - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"

test pkgMkIndex-2.3 {simple package - direct loading is default} {
    pkgtest::runIndex $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"

removeFile [file join pkg simple.tcl]

makeFile {
#  Contains global symbols, used to check that they don't have a leading ::
package provide global 1.0
proc global_lower { stg } {
    return [string tolower $stg]
}
proc global_upper { stg } {
    return [string toupper $stg]
}
} [file join pkg global.tcl]

test pkgMkIndex-3.1 {simple package with global symbols} {
    pkgtest::runIndex -lazy $fullPkgPath global.tcl
} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}

removeFile [file join pkg global.tcl]

makeFile {
#  This package is required by pkg1.
#  This package is split into two files, to test packages that are split
#  over multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
    namespace export p2-1
}
proc pkg2::p2-1 { num } {
    return [expr $num * 2]
}
} [file join pkg pkg2_a.tcl]

makeFile {
#  This package is required by pkg1.
#  This package is split into two files, to test packages that are split
#  over multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
    namespace export p2-2
}
proc pkg2::p2-2 { num } {
    return [expr $num * 3]
}
} [file join pkg pkg2_b.tcl]

test pkgMkIndex-4.1 {split package} {
    pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}

test pkgMkIndex-4.2 {split package - direct loading} {
    pkgtest::runIndex -direct $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
[list source [file join $fullPkgPath pkg2_b.tcl]]}}}"

# Add the direct1 directory to auto_path, so that the direct1 package 
# can be found.
set direct1 [makeDirectory direct1]
lappend auto_path $direct1
makeFile {
#  This is referenced by pkgIndex.tcl as a -direct script.
package provide direct1 1.0
namespace eval direct1 {
    namespace export pd1 pd2
}
proc direct1::pd1 { stg } {
    return [string tolower $stg]
}
proc direct1::pd2 { stg } {
    return [string toupper $stg]
}
} [file join direct1 direct1.tcl]
pkg_mkIndex -direct $direct1 direct1.tcl

makeFile {
#  Does a package require of direct1, whose pkgIndex.tcl entry
#  is created above with option -direct.  This tests that pkg_mkIndex
#  can handle code that is sourced in pkgIndex.tcl files.
package require direct1
package provide std 1.0
namespace eval std {
    namespace export p1 p2
}
proc std::p1 { stg } {
    return [string tolower $stg]
}
proc std::p2 { stg } {
    return [string toupper $stg]
}
} [file join pkg std.tcl]

test pkgMkIndex-5.1 {requires -direct package} {
    pkgtest::runIndex -lazy $fullPkgPath std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}

removeFile [file join direct1 direct1.tcl]
file delete [file join $direct1 pkgIndex.tcl]
removeDirectory direct1
removeFile [file join pkg std.tcl]

makeFile {
#  This package requires pkg3, but it does
#  not use any of pkg3's procs in the code that is executed by the file
#  (i.e. references to pkg3's procs are in the proc bodies only).
package require pkg3 1.0
package provide pkg1 1.0
namespace eval pkg1 {
    namespace export p1-1 p1-2
}
proc pkg1::p1-1 { num } {
    return [pkg3::p3-1 $num]
}
proc pkg1::p1-2 { num } {
    return [pkg3::p3-2 $num]
}
} [file join pkg pkg1.tcl]

makeFile {
package provide pkg3 1.0
namespace eval pkg3 {
    namespace export p3-1 p3-2
}
proc pkg3::p3-1 { num } {
    return {[expr $num * 2]}
}
proc pkg3::p3-2 { num } {
    return {[expr $num * 3]}
}
} [file join pkg pkg3.tcl]

test pkgMkIndex-6.1 {pkg1 requires pkg3} {
    pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}

test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath pkg1.tcl pkg3.tcl
} "0 {{pkg1:1.0 {[list source [file join $fullPkgPath pkg1.tcl]]}} {pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}}}"

removeFile [file join pkg pkg1.tcl]

makeFile {
#  This package requires pkg3, and it calls
#  a pkg3 proc in the code that is executed by the file
package require pkg3 1.0
package provide pkg4 1.0
namespace eval pkg4 {
    namespace export p4-1 p4-2
    variable m2 [pkg3::p3-1 10]
}
proc pkg4::p4-1 { num } {
    variable m2
    return [expr {$m2 * $num}]
}
proc pkg4::p4-2 { num } {
    return [pkg3::p3-2 $num]
}
} [file join pkg pkg4.tcl]

test pkgMkIndex-7.1 {pkg4 uses pkg3} {
    pkgtest::runIndex -lazy $fullPkgPath pkg4.tcl pkg3.tcl
} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}}

test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath pkg4.tcl pkg3.tcl
} "0 {{pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}} {pkg4:1.0 {[list source [file join $fullPkgPath pkg4.tcl]]}}}"

removeFile [file join pkg pkg4.tcl]
removeFile [file join pkg pkg3.tcl]

makeFile {
#  This package requires pkg2, and it calls
#  a pkg2 proc in the code that is executed by the file.
#  Pkg2 is a split package.
package require pkg2 1.0
package provide pkg5 1.0
namespace eval pkg5 {
    namespace export p5-1 p5-2
    variable m2 [pkg2::p2-1 10]
    variable m3 [pkg2::p2-2 10]
}
proc pkg5::p5-1 { num } {
    variable m2
    return [expr {$m2 * $num}]
}
proc pkg5::p5-2 { num } {
    variable m2
    return [expr {$m2 * $num}]
}
} [file join pkg pkg5.tcl]

test pkgMkIndex-8.1 {pkg5 uses pkg2} {
    pkgtest::runIndex -lazy $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}}

test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
    pkgtest::runIndex -direct $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
[list source [file join $fullPkgPath pkg2_b.tcl]]}} {pkg5:1.0 {[list source [file join $fullPkgPath pkg5.tcl]]}}}"

removeFile [file join pkg pkg5.tcl]
removeFile [file join pkg pkg2_a.tcl]
removeFile [file join pkg pkg2_b.tcl]

makeFile {
#  This package requires circ2, and circ2
#  requires circ3, which in turn requires circ1.
#  In case of cirularities, pkg_mkIndex should give up when it gets stuck.
package require circ2 1.0
package provide circ1 1.0
namespace eval circ1 {
    namespace export c1-1 c1-2 c1-3 c1-4
}
proc circ1::c1-1 { num } {
    return [circ2::c2-1 $num]
}
proc circ1::c1-2 { num } {
    return [circ2::c2-2 $num]
}
proc circ1::c1-3 {} {
    return 10
}
proc circ1::c1-4 {} {
    return 20
}
} [file join pkg circ1.tcl]

makeFile {
#  This package is required by circ1, and
#  requires circ3. Circ3, in turn, requires circ1 to give us a circularity.
package require circ3 1.0
package provide circ2 1.0
namespace eval circ2 {
    namespace export c2-1 c2-2
}
proc circ2::c2-1 { num } {
    return [expr $num * [circ3::c3-1]]
}
proc circ2::c2-2 { num } {
    return [expr $num * [circ3::c3-2]]
}
} [file join pkg circ2.tcl]

makeFile {
#  This package is required by circ2, and in
#  turn requires circ1. This closes the circularity.
package require circ1 1.0
package provide circ3 1.0
namespace eval circ3 {
    namespace export c3-1 c3-4
}
proc circ3::c3-1 {} {
    return [circ1::c1-3]
}
proc circ3::c3-2 {} {
    return [circ1::c1-4]
}
} [file join pkg circ3.tcl]

test pkgMkIndex-9.1 {circular packages} {
    pkgtest::runIndex -lazy $fullPkgPath circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}

removeFile [file join pkg circ1.tcl]
removeFile [file join pkg circ2.tcl]
removeFile [file join pkg circ3.tcl]

# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join [file dirname [info nameofexecutable]] dltest \
	pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
::tcltest::testConstraint $dll [file exists $x]

if {[testConstraint $dll]} {
makeFile {
#  This package provides Pkga, which is also provided by a DLL.
package provide Pkga 1.0
proc pkga_neq { x } {
    return [expr {! [pkgq_eq $x]}]
}
} [file join pkg pkga.tcl]
file copy -force $x $fullPkgPath
}
testConstraint exec [llength [info commands ::exec]]

test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
    # Do all [load]ing of shared libraries in another process, so 
    # we can delete the file and not get stuck because we're holding
    # a reference to it.
    set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
    exec [interpreter] << $cmd
    pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
    # Do all [load]ing of shared libraries in another process, so 
    # we can delete the file and not get stuck because we're holding
    # a reference to it.
    #
    # This test depends on context from prior test, so repeat it.
    set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n"
    append script \
	    "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
    exec [interpreter] << $script
    pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
} {0 {}}

if {[testConstraint $dll]} {
file delete -force [file join $fullPkgPath [file tail $x]]
removeFile [file join pkg pkga.tcl]
}

# Tolerate "namespace import" at the global scope

makeFile {
package provide fubar 1.0
namespace eval ::fubar:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}
proc ::fubar::foo {bar} {
    puts "$bar"
    return true
}
namespace import ::fubar::foo
} [file join pkg import.tcl]

test pkgMkIndex-11.1 {conflicting namespace imports} {
    pkgtest::runIndex -lazy $fullPkgPath import.tcl
} {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}}

removeFile [file join pkg import.tcl]

# Verify that the auto load list generated is correct even when there
# is a proc name conflict between two namespaces (ie, ::foo::baz and
# ::bar::baz)

makeFile {
package provide football 1.0
namespace eval ::pro:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}
namespace eval ::college:: {
    #
    # export only public functions.
    #
    namespace export {[a-z]*}
}
proc ::pro::team {} {
    puts "go packers!"
    return true
}
proc ::college::team {} {
    puts "go badgers!"
    return true
}
} [file join pkg samename.tcl]

test pkgMkIndex-12.1 {same name procs in different namespace} {
    pkgtest::runIndex -lazy $fullPkgPath samename.tcl
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}

removeFile [file join pkg samename.tcl]

# Proc names with embedded spaces are properly listed (ie, correct number of
# braces) in result
makeFile {
package provide spacename 1.0
proc {a b} {} {}
proc {c d} {} {}
} [file join pkg spacename.tcl]

test pkgMkIndex-13.1 {proc names with embedded spaces} {
    pkgtest::runIndex -lazy $fullPkgPath spacename.tcl
} {0 {{spacename:1.0 {tclPkgSetup {spacename.tcl source {{a b} {c d}}}}}}}

removeFile [file join pkg spacename.tcl]

# Test the pkg_compareExtension helper function
test pkgMkIndex-14.1 {pkg_compareExtension} {unixOnly} {
    pkg_compareExtension foo.so .so
} 1
test pkgMkIndex-14.2 {pkg_compareExtension} {unixOnly} {
    pkg_compareExtension foo.so.bar .so
379
380
381
382
383
384
385
386


387
388
389
390
391
    pkg_compareExtension foo .so
} 0
test pkgMkIndex-14.6 {pkg_compareExtension} {unixOnly} {
    pkg_compareExtension foo.so.1.2.bar .so
} 0

# cleanup



namespace delete pkgtest
cd $origDir
::tcltest::cleanupTests
return









>
>

<



682
683
684
685
686
687
688
689
690
691
692

693
694
695
    pkg_compareExtension foo .so
} 0
test pkgMkIndex-14.6 {pkg_compareExtension} {unixOnly} {
    pkg_compareExtension foo.so.1.2.bar .so
} 0

# cleanup

removeDirectory pkg

namespace delete pkgtest

::tcltest::cleanupTests
return

Changes to tests/reg.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer.  All rights reserved.
#
# RCS: @(#) $Id: reg.test,v 1.13 2000/04/10 17:19:03 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# All tests require the testregexp command, return if this
# command doesn't exist

set ::tcltest::testConstraints(testregexp) \
	[expr {[info commands testregexp] != {}}]
set ::tcltest::testConstraints(localeRegexp) 0

# This file uses some custom procedures, defined below, for regexp regression
# testing.  The name of the procedure indicates the general nature of the
# test:
#	e	compile error expected
#	f	match failure expected
#	m	successful match











|


|






|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer.  All rights reserved.
#
# RCS: @(#) $Id: reg.test,v 1.13.18.1 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# All tests require the testregexp command, return if this
# command doesn't exist

::tcltest::testConstraint testregexp \
	[expr {[info commands testregexp] != {}}]
::tcltest::testConstraint localeRegexp 0

# This file uses some custom procedures, defined below, for regexp regression
# testing.  The name of the procedure indicates the general nature of the
# test:
#	e	compile error expected
#	f	match failure expected
#	m	successful match
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
# The ! flag is used to indicate expected match failure (for REG_EXPECT,
#  which wants argument testing even in the event of failure).
proc matchexpected {opts testid flags re target args} {
	global prefix description ask regBug

    if {[info exists regBug] && $regBug} {
	# This will register as a skipped test
	test $prefix.[tno $testid] [desc $testid] knownBug {} {}
	return
    }

	# Tcl locale stuff doesn't do the ch/xy test fakery yet
	if {[string first "+" $flags] >= 0} {
	    # This will register as a skipped test
	    test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}







|







263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
# The ! flag is used to indicate expected match failure (for REG_EXPECT,
#  which wants argument testing even in the event of failure).
proc matchexpected {opts testid flags re target args} {
	global prefix description ask regBug

    if {[info exists regBug] && $regBug} {
	# This will register as a skipped test
	test $prefix.[tno $testid] [desc $testid] knownBug {format 0} {1}
	return
    }

	# Tcl locale stuff doesn't do the ch/xy test fakery yet
	if {[string first "+" $flags] >= 0} {
	    # This will register as a skipped test
	    test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
983
984
985
986
987
988
989








990
991
992
993
994
# back to normal stuff
m  9	HLP	{(?n)^(?![t#])\S+}	"tk\n\n#\n#\nit0"	it0


# flush any leftover complaints
doing 0 "flush"









# cleanup
::tcltest::cleanupTests
return









>
>
>
>
>
>
>
>



<
<
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000


# back to normal stuff
m  9	HLP	{(?n)^(?![t#])\S+}	"tk\n\n#\n#\nit0"	it0


# flush any leftover complaints
doing 0 "flush"

# Tests resulting from bugs reported by users
test reg-31.1 {[[:xdigit:]] behaves correctly when followed by [[:space:]]} {
    set str {2:::DebugWin32}
    set re {([[:xdigit:]])([[:space:]]*)}
    list [regexp $re $str match xdigit spaces] $match $xdigit $spaces
    # Code used to produce {1 2:::DebugWin32 2 :::DebugWin32} !!!
} {1 2 2 {}}

# cleanup
::tcltest::cleanupTests
return


Changes to tests/regexp.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: regexp.test,v 1.17.4.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {unset foo}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: regexp.test,v 1.17.4.2 2002/08/20 20:25:28 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

catch {unset foo}
429
430
431
432
433
434
435
436
437
438


439
440
441
442
443
444
445
446
447
    regexp .*d e
    regexp .*e f
    set x .
    append x *a
    regexp -nocase $x bbba
} 1

# There is no exec on the Mac ...

test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} {unixOrPc} {


    makeFile {puts [regexp {} foo]} junk.tcl
    exec $::tcltest::tcltest junk.tcl
} 1

test regexp-15.1 {regexp -start} {
    catch {unset x}
    list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {







<
|
|
>
>
|
<







429
430
431
432
433
434
435

436
437
438
439
440

441
442
443
444
445
446
447
    regexp .*d e
    regexp .*e f
    set x .
    append x *a
    regexp -nocase $x bbba
} 1


testConstraint exec [llength [info commands exec]]
test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} {
	exec
} {
    exec [interpreter] [makeFile {puts [regexp {} foo]} junk.tcl]

} 1

test regexp-15.1 {regexp -start} {
    catch {unset x}
    list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {
Changes to tests/regexpComp.test.
588
589
590
591
592
593
594
595
596
597


598
599
600
601
602
603
604
605
606
	regexp .*e f
	set x .
	append x *a
	regexp -nocase $x bbba
    }
} 1

# There is no exec on the Mac ...

test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} {unixOrPc} {


    makeFile {puts [regexp {} foo]} junk.tcl
    exec $::tcltest::tcltest junk.tcl
} 1

test regexp-15.1 {regexp -start} {
    catch {unset x}
    list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {







<
|
|
>
>
|
<







588
589
590
591
592
593
594

595
596
597
598
599

600
601
602
603
604
605
606
	regexp .*e f
	set x .
	append x *a
	regexp -nocase $x bbba
    }
} 1


testConstraint exec [llength [info commands exec]]
test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} {
	exec
} {
    exec [interpreter] [makeFile {puts [regexp {} foo]} junk.tcl]

} 1

test regexp-15.1 {regexp -start} {
    catch {unset x}
    list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {
Changes to tests/result.test.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testsaveresult command

set ::tcltest::testConstraints(testsaveresult) \
	[expr {[info commands testsaveresult] != {}}]

test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult append {set x 42} 0







|





|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Some tests require the testsaveresult command

::tcltest::testConstraint testsaveresult \
	[expr {[info commands testsaveresult] != {}}]

test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
    testsaveresult append {set x 42} 0
Changes to tests/scan.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
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.11.14.1 2002/06/10 05:33:16 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(64bitInts) \
	[expr {0x80000000 > 0}]

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
    list [scan \]foo {%[]f]} x] $x
} {1 \]f}













|


|



<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
# Commands covered:  scan
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: scan.test,v 1.11.14.2 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}


::tcltest::testConstraint 64bitInts [expr {0x80000000 > 0}]

test scan-1.1 {BuildCharSet, CharInSet} {
    list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
    list [scan \]foo {%[]f]} x] $x
} {1 \]f}
Changes to tests/set-old.test.
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: set-old.test,v 1.14 2001/03/15 14:36:32 dkf Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc ignore args {}







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: set-old.test,v 1.14.14.1 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc ignore args {}
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
    list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
} {{e1 e2 e3} 0 v2}
test set-old-8.37.5 {array command, set with non-existent namespace} {
    list [catch {array set bogusnamespace::var {}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.37.6 {array command, set with non-existent namespace} {
    list [catch {array set bogusnamespace::var {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var(a)": parent namespace doesn't exist}}
test set-old-8.37.7 {array command, set with non-existent namespace} {
    list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
test set-old-8.38 {array command, size option} {
    catch {unset a}
    array size a
} {0}







|







543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
    list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
} {{e1 e2 e3} 0 v2}
test set-old-8.37.5 {array command, set with non-existent namespace} {
    list [catch {array set bogusnamespace::var {}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.37.6 {array command, set with non-existent namespace} {
    list [catch {array set bogusnamespace::var {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.37.7 {array command, set with non-existent namespace} {
    list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
test set-old-8.38 {array command, size option} {
    catch {unset a}
    array size a
} {0}
Changes to tests/socket.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: socket.test,v 1.20.2.2 2002/06/10 05:33:16 wolfsuit 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












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# Commands tested in this file: socket.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: socket.test,v 1.20.2.3 2002/08/20 20:25:29 das Exp $

# Running socket tests with a remote server:
# ------------------------------------------
# 
# Some tests in socket.test depend on the existence of a remote server to
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Some tests require the testthread and exec commands

set ::tcltest::testConstraints(testthread) \
	[expr {[info commands testthread] != {}}]
set ::tcltest::testConstraints(exec) [expr {[info commands exec] != {}}]

#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
	set remoteServerIP $env(remoteServerIP)







<
|
|
|
<

<
<
|
<
|
|







58
59
60
61
62
63
64

65
66
67

68


69

70
71
72
73
74
75
76
77
78
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.


package require tcltest 2
namespace import -force ::tcltest::*


# Some tests require the testthread and exec commands


testConstraint testthread [llength [info commands testthread]]

testConstraint exec [llength [info commands exec]]

# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#

if {![info exists remoteServerIP]} {
    if {[info exists env(remoteServerIP)]} {
	set remoteServerIP $env(remoteServerIP)
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
	} else {
	    set remoteServerIP 127.0.0.1
	    # Be *extra* careful in case this file is sourced from
	    # a directory other than the current one...
	    set remoteFile [file join [pwd] [file dirname [info script]] \
		    remote.tcl]
	    if {[catch {set remoteProcChan \
				[open "|[list $::tcltest::tcltest $remoteFile \
					-serverIsSilent \
					-port $remoteServerPort \
					-address $remoteServerIP]" \
					w+]} \
		   msg] == 0} {
		after 1000
		if {[catch {set commandSocket [socket $remoteServerIP \
				$remoteServerPort]} msg] == 0} {
		    fconfigure $commandSocket -translation crlf -buffering line
		} else {
		    set noRemoteTestReason $msg
		    set doTestsWithRemoteServer 0
		}
	    } else {
		set noRemoteTestReason "$msg $::tcltest::tcltest"
		set doTestsWithRemoteServer 0
	    }
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}







|














|







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
	} else {
	    set remoteServerIP 127.0.0.1
	    # Be *extra* careful in case this file is sourced from
	    # a directory other than the current one...
	    set remoteFile [file join [pwd] [file dirname [info script]] \
		    remote.tcl]
	    if {[catch {set remoteProcChan \
				[open "|[list [interpreter] $remoteFile \
					-serverIsSilent \
					-port $remoteServerPort \
					-address $remoteServerIP]" \
					w+]} \
		   msg] == 0} {
		after 1000
		if {[catch {set commandSocket [socket $remoteServerIP \
				$remoteServerPort]} msg] == 0} {
		    fconfigure $commandSocket -translation crlf -buffering line
		} else {
		    set noRemoteTestReason $msg
		    set doTestsWithRemoteServer 0
		}
	    } else {
		set noRemoteTestReason "$msg [interpreter]"
		set doTestsWithRemoteServer 0
	    }
	}
    } else {
	fconfigure $commandSocket -translation crlf -buffering line
    }
}
243
244
245
246
247
248
249


250
251
252
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
    list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}



test socket-2.1 {tcp connection} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 10000 "set x timed_out"]
	set f [socket -server accept 0]
	proc accept {file addr port} {
	    global x
	    set x done
            close $file
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
	puts $x
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    gets $f listen
    if {[catch {socket 127.0.0.1 $listen} msg]} {
        set x $msg
    } else {
        lappend x [gets $f]
        close $msg
    }
    lappend x [gets $f]
    close $f
    set x
} {ready done {}}

if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 10000 "set x timeout"]
        set f [socket -server accept 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file] $port"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    gets $f listen
    global port
    if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
        set x $sock
	close [socket 127.0.0.1 $listen]
	puts stderr $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2830]
	proc accept {file addr port} {
            global x
            puts "[gets $file] $addr"
            close $file
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept -myaddr [info hostname] 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file]"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    gets $f listen
    if {[catch {socket [info hostname] $listen} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 10000 "set x timeout"]
        set f [socket -server accept 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file]"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    gets $f listen
    if {[catch {socket 127.0.0.1 $listen} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock







>
>



|
















|




















|
















|


















|















|














|


|













|


|












|
















|







238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
    list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
    list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}

set path(script) [makeFile {} script]

test socket-2.1 {tcp connection} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timed_out"]
	set f [socket -server accept 0]
	proc accept {file addr port} {
	    global x
	    set x done
            close $file
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
	puts $x
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
    if {[catch {socket 127.0.0.1 $listen} msg]} {
        set x $msg
    } else {
        lappend x [gets $f]
        close $msg
    }
    lappend x [gets $f]
    close $f
    set x
} {ready done {}}

if [info exists port] {
    incr port
} else { 
    set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timeout"]
        set f [socket -server accept 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file] $port"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
    global port
    if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
        set x $sock
	close [socket 127.0.0.1 $listen]
	puts stderr $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket  -server accept 2830]
	proc accept {file addr port} {
            global x
            puts "[gets $file] $addr"
            close $file
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set timer [after 2000 "set x done"]
        set f [socket -server accept -myaddr 127.0.0.1 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file]"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
    if {[catch {socket 127.0.0.1 $listen} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timeout"]
        set f [socket -server accept 0]
	proc accept {file addr port} {
            global x
            puts "[gets $file]"
            close $file
            set x done
	}
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f x
    gets $f listen
    if {[catch {socket 127.0.0.1 $listen} sock]} {
        set x $sock
    } else {
        puts $sock hello
	flush $sock
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set timer [after 10000 "set x timeout"]
	set f [socket -server accept 0]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
	    fconfigure $s -translation lf -buffering line
        }







|







424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
	}
	close $sock
    }
    set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set timer [after 10000 "set x timeout"]
	set f [socket -server accept 0]
	proc accept {s a p} {
            fileevent $s readable [list echo $s]
	    fconfigure $s -translation lf -buffering line
        }
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
	puts $x
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    fconfigure $s -buffering line -translation lf
    puts $s "hello abcdefghijklmnop"
    after 1000
    set x [gets $s]







|







450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
	puts [lindex [fconfigure $f -sockname] 2]
	vwait x
	after cancel $timer
	close $f
	puts $x
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    fconfigure $s -buffering line -translation lf
    puts $s "hello abcdefghijklmnop"
    after 1000
    set x [gets $s]
494
495
496
497
498
499
500
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
	puts [lindex [fconfigure $f -sockname] 2]
	set timer [after 20000 "set x done"]
	vwait x
	after cancel $timer
	close $f
	puts "done $i"
    } script
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    fconfigure $s -buffering line
    catch {
	for {set x 0} {$x < 50} {incr x} {
	    puts $s "hello abcdefghijklmnop"
	    gets $s
	}
    }
    close $s
    catch {set x [gets $f]}
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
    set s [socket -server accept 0]
    removeFile script
    set f [open script w]
    puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    after 100
    set x [list [catch {close $f} msg]]
    regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
    lappend x $msg
    close $s
    set x







|


















|


|







491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
	puts [lindex [fconfigure $f -sockname] 2]
	set timer [after 20000 "set x done"]
	vwait x
	after cancel $timer
	close $f
	puts "done $i"
    } script
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    fconfigure $s -buffering line
    catch {
	for {set x 0} {$x < 50} {incr x} {
	    puts $s "hello abcdefghijklmnop"
	    gets $s
	}
    }
    close $s
    catch {set x [gets $f]}
    close $f
    set x
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
    set s [socket -server accept 0]
    removeFile script
    set f [open $path(script) w]
    puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    after 100
    set x [list [catch {close $f} msg]]
    regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
    lappend x $msg
    close $s
    set x
579
580
581
582
583
584
585
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
    close $sock
    set result
} {a:one b: c:two}


test socket-3.1 {socket conflict} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set f [socket -server accept 0]
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	gets stdin
	close $f
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r+]
    gets $f
    gets $f listen
    set x [list [catch {socket -server accept $listen} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
	set s [socket -server accept 0]
	proc accept {s a p} {







|








|










|







576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
    close $sock
    set result
} {a:one b: c:two}


test socket-3.1 {socket conflict} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set f [socket -server accept 0]
	puts ready
	puts [lindex [fconfigure $f -sockname] 2]
	gets stdin
	close $f
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    gets $f
    gets $f listen
    set x [list [catch {socket -server accept $listen} msg] \
		$msg]
    puts $f bye
    close $f
    set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set t1 [after 30000 "set x timed_out"]
	set t2 [after 31000 "set x timed_out"]
	set t3 [after 32000 "set x timed_out"]
	set counter 0
	set s [socket -server accept 0]
	proc accept {s a p} {
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
	after cancel $t2
	vwait x
	after cancel $t3
	close $s
	puts $x
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r+]
    set x [gets $f]
    gets $f listen
    set s1 [socket 127.0.0.1 $listen]
    fconfigure $s1 -buffering line
    set s2 [socket 127.0.0.1 $listen]
    fconfigure $s2 -buffering line
    set s3 [socket 127.0.0.1 $listen]







|







629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
	after cancel $t2
	vwait x
	after cancel $t3
	close $s
	puts $x
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    set x [gets $f]
    gets $f listen
    set s1 [socket 127.0.0.1 $listen]
    fconfigure $s1 -buffering line
    set s2 [socket 127.0.0.1 $listen]
    fconfigure $s2 -buffering line
    set s3 [socket 127.0.0.1 $listen]
659
660
661
662
663
664
665
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
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set port [gets stdin]
	set s [socket 127.0.0.1 $port]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
	    puts $s hello
	    gets $s
	}
	close $s
	puts bye
	gets stdin
    }
    close $f
    set p1 [open "|[list $::tcltest::tcltest script]" r+]
    fconfigure $p1 -buffering line
    set p2 [open "|[list $::tcltest::tcltest script]" r+]
    fconfigure $p2 -buffering line
    set p3 [open "|[list $::tcltest::tcltest script]" r+]
    fconfigure $p3 -buffering line
    proc accept {s a p} {
	fconfigure $s -buffering line
	fileevent $s readable [list echo $s]
    }
    proc echo {s} {
	global x







|













|

|

|







656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test socket-4.1 {server with several clients} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set port [gets stdin]
	set s [socket 127.0.0.1 $port]
	fconfigure $s -buffering line
	for {set i 0} {$i < 100} {incr i} {
	    puts $s hello
	    gets $s
	}
	close $s
	puts bye
	gets stdin
    }
    close $f
    set p1 [open "|[list [interpreter] $path(script)]" r+]
    fconfigure $p1 -buffering line
    set p2 [open "|[list [interpreter] $path(script)]" r+]
    fconfigure $p2 -buffering line
    set p3 [open "|[list [interpreter] $path(script)]" r+]
    fconfigure $p3 -buffering line
    proc accept {s a p} {
	fconfigure $s -buffering line
	fileevent $s readable [list echo $s]
    }
    proc echo {s} {
	global x
759
760
761
762
763
764
765
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
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	gets stdin port
	socket 127.0.0.1 $port
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r+]
    proc bgerror args {
	global x
	set x $args
    }
    proc accept {s a p} {expr 10 / 0}
    set s [socket -server accept 0]
    puts $f [lindex [fconfigure $s -sockname] 2]
    close $f
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set ss [socket -server accept 0]
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	puts [lindex [fconfigure $ss -sockname] 2]
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    set p [fconfigure $s -peername]
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] $listen]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	set ss [socket -server accept 2821]
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	puts [lindex [fconfigure $ss -sockname] 2]
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    set p [fconfigure $s -sockname]
    close $s
    close $f
    list [llength $p] \







|





|


















|













|













|













|







756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test socket-6.1 {accept callback error} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	gets stdin port
	socket 127.0.0.1 $port
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r+]
    proc bgerror args {
	global x
	set x $args
    }
    proc accept {s a p} {expr 10 / 0}
    set s [socket -server accept 0]
    puts $f [lindex [fconfigure $s -sockname] 2]
    close $f
    set timer [after 10000 "set x timed_out"]
    vwait x
    after cancel $timer
    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

test socket-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set ss [socket -server accept 0]
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	puts [lindex [fconfigure $ss -sockname] 2]
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    set p [fconfigure $s -peername]
    close $s
    close $f
    set l ""
    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] $listen]
    lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	set ss [socket -server accept 2821]
	proc accept args {
	    global x
	    set x done
	}
	puts ready
	puts [lindex [fconfigure $ss -sockname] 2]
	set timer [after 10000 "set x timed_out"]
	vwait x
	after cancel $timer
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    gets $f
    gets $f listen
    set s [socket 127.0.0.1 $listen]
    set p [fconfigure $s -sockname]
    close $s
    close $f
    list [llength $p] \
1386
1387
1388
1389
1390
1391
1392



1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566




test socket-12.1 {testing inheritance of server sockets} {socket exec} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever
    }
    close $f

    # Script2 creates the server socket, launches script1,
    # waits a second, and exits.  The server socket will now
    # be closed unless script1 inherited it.

    set f [open script2 w]
    puts $f [list set tcltest $::tcltest::tcltest]
    puts $f {
	set f [socket -server accept 0]
	puts [lindex [fconfigure $f -sockname] 2]
	proc accept { file addr port } {
	    close $file
	}
	exec $tcltest script1 &
	close $f
	after 1000 exit
	vwait forever
    }
    close $f
	
    # Launch script2 and wait 5 seconds

    ### exec $::tcltest::tcltest script2 &
    set p [open "|[list $::tcltest::tcltest script2]" r]
    gets $p listen

    after 5000 { set ok_to_proceed 1 }
    vwait ok_to_proceed

    # If we can still connect to the server, the socket got inherited.

    if {[catch {socket 127.0.0.1 $listen} msg]} {
	set x {server socket was not inherited}
    } else {
	close $msg
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    close $p
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket exec} {
    removeFile script1
    removeFile script2

    # Script1 is just a 20 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open script1 w]
    puts $f {
	after 20000 exit
	vwait forever
    }
    close $f

    # Script2 opens the client socket and writes to it.  It then
    # launches script1 and exits.  If the child process inherited the
    # client socket, the socket will still be open.

    set f [open script2 w]
    puts $f [list set tcltest $::tcltest::tcltest]
    puts $f {
        gets stdin port
	set f [socket 127.0.0.1 $port]
	exec $tcltest script1 &
	puts $f testing
	flush $f
	after 1000 exit
	vwait forever
    }
    close $f

    # Create the server socket

    set server [socket -server accept 0]
    proc accept { file host port } {
	# When the client connects, establish the read handler







>
>
>
|






|










|
|
|





|



|




|
|



















|






|










|
|
|


|




|







1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    sendCommand {close $l}
    set count
} 65566

set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]

test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
    removeFile script1
    removeFile script2

    # Script1 is just a 10 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open $path(script1) w]
    puts $f {
	after 10000 exit
	vwait forever
    }
    close $f

    # Script2 creates the server socket, launches script1,
    # waits a second, and exits.  The server socket will now
    # be closed unless script1 inherited it.

    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [format {
	set f [socket -server accept 0]
	puts [lindex [fconfigure $f -sockname] 2]
	proc accept { file addr port } {
	    close $file
	}
	exec $tcltest "%s" &
	close $f
	after 1000 exit
	vwait forever
    } $path(script1)]
    close $f
	
    # Launch script2 and wait 5 seconds

    ### exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" r]
    gets $p listen

    after 5000 { set ok_to_proceed 1 }
    vwait ok_to_proceed

    # If we can still connect to the server, the socket got inherited.

    if {[catch {socket 127.0.0.1 $listen} msg]} {
	set x {server socket was not inherited}
    } else {
	close $msg
	set x {server socket was inherited}
    }

    removeFile script1
    removeFile script2
    close $p
    set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
    removeFile script1
    removeFile script2

    # Script1 is just a 20 second delay.  If the server socket
    # is inherited, it will be held open for 10 seconds

    set f [open $path(script1) w]
    puts $f {
	after 20000 exit
	vwait forever
    }
    close $f

    # Script2 opens the client socket and writes to it.  It then
    # launches script1 and exits.  If the child process inherited the
    # client socket, the socket will still be open.

    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [format {
        gets stdin port
	set f [socket 127.0.0.1 $port]
	exec $tcltest "%s" &
	puts $f testing
	flush $f
	after 1000 exit
	vwait forever
    } $path(script1)]
    close $f

    # Create the server socket

    set server [socket -server accept 0]
    proc accept { file host port } {
	# When the client connects, establish the read handler
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
    # If the socket doesn't hit end-of-file in 10 seconds, the
    # script1 process must have inherited the client.

    set failed 0
    after 10000 [list set failed 1]

    # Launch the script2 process
    ### exec $::tcltest::tcltest script2 &

    set p [open "|[list $::tcltest::tcltest script2]" w]
    puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p

    vwait x
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    close $p
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket exec} {
    removeFile script1
    removeFile script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever
    }
    close $f

    set f [open script2 w]
    puts $f [list set tcltest $::tcltest::tcltest]
    puts $f {
	set server [socket -server accept 0]
	puts stdout [lindex [fconfigure $server -sockname] 2]
	proc accept { file host port } {
	    global tcltest
	    puts $file {test data on socket}
	    exec $tcltest script1 &
	    after 1000 exit
	}
	vwait forever
    }
    close $f

    # Launch the script2 process and connect to it.  See how long
    # the socket stays open

    ## exec $::tcltest::tcltest script2 &
    set p [open "|[list $::tcltest::tcltest script2]" r]
    gets $p listen

    after 1000 set ok_to_proceed 1
    vwait ok_to_proceed

    set f [socket 127.0.0.1 $listen]
    fconfigure $f -buffering full -blocking 0







|

|











|



|






|
|
|





|



|





|
|







1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
    # If the socket doesn't hit end-of-file in 10 seconds, the
    # script1 process must have inherited the client.

    set failed 0
    after 10000 [list set failed 1]

    # Launch the script2 process
    ### exec [interpreter] script2 &

    set p [open "|[list [interpreter] $path(script2)]" w]
    puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p

    vwait x
    if {!$failed} {
	vwait failed
    }
    removeFile script1
    removeFile script2
    close $p
    set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
    removeFile script1
    removeFile script2

    set f [open $path(script1) w]
    puts $f {
	after 10000 exit
	vwait forever
    }
    close $f

    set f [open $path(script2) w]
    puts $f [list set tcltest [interpreter]]
    puts $f [format {
	set server [socket -server accept 0]
	puts stdout [lindex [fconfigure $server -sockname] 2]
	proc accept { file host port } {
	    global tcltest
	    puts $file {test data on socket}
	    exec $tcltest "%s" &
	    after 1000 exit
	}
	vwait forever
    } $path(script1)]
    close $f

    # Launch the script2 process and connect to it.  See how long
    # the socket stays open

    ## exec [interpreter] script2 &
    set p [open "|[list [interpreter] $path(script2)]" r]
    gets $p listen

    after 1000 set ok_to_proceed 1
    vwait ok_to_proceed

    set f [socket 127.0.0.1 $listen]
    fconfigure $f -buffering full -blocking 0
Changes to tests/source.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
# Commands covered:  source
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: source.test,v 1.7 2000/05/11 00:16:53 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}


test source-1.1 {source command} {
    set x "old x value"
    set y "old y value"
    set z "old z value"
    makeFile {
	set x 22
	set y 33
	set z 44
    } source.file
    source source.file
    list $x $y $z
} {22 33 44}
test source-1.2 {source command} {
    makeFile {list result} source.file
    source source.file
} result
test source-1.3 {source command} {
    set y {\ }

    set fd [open source.file w]
    fconfigure $fd -translation lf
    puts -nonewline $fd "list a b c "
    puts $fd [string index $y 0]
    puts $fd "d e f"
    close $fd

    source source.file
} {a b c d e f}

test source-2.3 {source error conditions} {
    makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file
    list [catch {source source.file} msg] $msg $errorInfo
} {1 {error in sourced file} {error in sourced file
    while executing
"error "error in sourced file""
    (file "source.file" line 3)
    invoked from within
"source source.file"}}
test source-2.4 {source error conditions} {
    makeFile {break} source.file
    catch {source source.file}
} 3
test source-2.5 {source error conditions} {
    makeFile {continue} source.file
    catch {source source.file}
} 4
test source-2.6 {source error conditions} {
    normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode]
} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}

test source-3.1 {return in middle of source file} {
    makeFile {
	set x new-x
	return allDone
	set y new-y
    } source.file
    set x old-x
    set y old-y
    set z [source source.file]
    list $x $y $z
} {new-x old-y allDone}
test source-3.2 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code break "Silly result"
	set y new-y
    } source.file
    list [catch {source source.file} msg] $msg
} {3 {Silly result}}
test source-3.3 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code error "Simulated error"
	set y new-y
    } source.file
    list [catch {source source.file} msg] $msg $errorInfo $errorCode
} {1 {Simulated error} {Simulated error
    while executing
"source source.file"} NONE}
test source-3.4 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code error -errorinfo "Simulated errorInfo stuff"
	set y new-y
    } source.file
    list [catch {source source.file} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
    invoked from within
"source source.file"} NONE}
test source-3.5 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code error -errorinfo "Simulated errorInfo stuff" \
		-errorcode {a b c}
	set y new-y
    } source.file
    list [catch {source source.file} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
    invoked from within
"source source.file"} {a b c}}

# Test for the Macintosh specfic features of the source command
test source-4.1 {source error conditions} {macOnly} {
    list [catch {source -rsrc _no_exist_} msg] $msg
} [list 1 "The resource \"_no_exist_\" could not be loaded from application."]
test source-4.2 {source error conditions} {macOnly} {
    list [catch {source -rsrcid bad_id} msg] $msg













|






>









|




|




|






|








|
|

|
|

|


|



|













|








|







|


|






|


|







|


|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
# Commands covered:  source
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: source.test,v 1.7.14.1 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set sourcefile [makeFile "" source.file]
test source-1.1 {source command} {
    set x "old x value"
    set y "old y value"
    set z "old z value"
    makeFile {
	set x 22
	set y 33
	set z 44
    } source.file
    source $sourcefile
    list $x $y $z
} {22 33 44}
test source-1.2 {source command} {
    makeFile {list result} source.file
    source $sourcefile
} result
test source-1.3 {source command} {
    set y {\ }

    set fd [open $sourcefile w]
    fconfigure $fd -translation lf
    puts -nonewline $fd "list a b c "
    puts $fd [string index $y 0]
    puts $fd "d e f"
    close $fd

    source $sourcefile
} {a b c d e f}

test source-2.3 {source error conditions} {
    makeFile {
	set x 146
	error "error in sourced file"
	set y $x
    } source.file
    list [catch {source $sourcefile} msg] $msg $errorInfo
} [list 1 {error in sourced file} "error in sourced file
    while executing
\"error \"error in sourced file\"\"
    (file \"$sourcefile\" line 3)
    invoked from within
\"source \$sourcefile\""]
test source-2.4 {source error conditions} {
    makeFile {break} source.file
    catch {source $sourcefile}
} 3
test source-2.5 {source error conditions} {
    makeFile {continue} source.file
    catch {source $sourcefile}
} 4
test source-2.6 {source error conditions} {
    normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode]
} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}

test source-3.1 {return in middle of source file} {
    makeFile {
	set x new-x
	return allDone
	set y new-y
    } source.file
    set x old-x
    set y old-y
    set z [source $sourcefile]
    list $x $y $z
} {new-x old-y allDone}
test source-3.2 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code break "Silly result"
	set y new-y
    } source.file
    list [catch {source $sourcefile} msg] $msg
} {3 {Silly result}}
test source-3.3 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code error "Simulated error"
	set y new-y
    } source.file
    list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {Simulated error} {Simulated error
    while executing
"source $sourcefile"} NONE}
test source-3.4 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code error -errorinfo "Simulated errorInfo stuff"
	set y new-y
    } source.file
    list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
    invoked from within
"source $sourcefile"} NONE}
test source-3.5 {return with special code etc.} {
    makeFile {
	set x new-x
	return -code error -errorinfo "Simulated errorInfo stuff" \
		-errorcode {a b c}
	set y new-y
    } source.file
    list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
    invoked from within
"source $sourcefile"} {a b c}}

# Test for the Macintosh specfic features of the source command
test source-4.1 {source error conditions} {macOnly} {
    list [catch {source -rsrc _no_exist_} msg] $msg
} [list 1 "The resource \"_no_exist_\" could not be loaded from application."]
test source-4.2 {source error conditions} {macOnly} {
    list [catch {source -rsrcid bad_id} msg] $msg
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
    list [catch {source -bad_switch argument} msg] $msg
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test source-5.1 {source resource files} {macOnly} {
    list [catch {source -rsrc rsrcName bad_file} msg] $msg
} [list 1 "Error finding the file: \"bad_file\"."]
test source-5.2 {source resource files} {macOnly} {
    makeFile {return} source.file
    list [catch {source -rsrc rsrcName source.file} msg] $msg
} [list 1 "Error reading the file: \"source.file\"."]
test source-5.3 {source resource files} {macOnly} {
    testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return}
    set result [catch {source -rsrc rsrcName rsrc.file} msg]
    removeFile rsrc.file
    list $msg2 $result $msg
} [list ok 0 {}]
test source-5.4 {source resource files} {macOnly} {







|
|







141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
    list [catch {source -bad_switch argument} msg] $msg
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test source-5.1 {source resource files} {macOnly} {
    list [catch {source -rsrc rsrcName bad_file} msg] $msg
} [list 1 "Error finding the file: \"bad_file\"."]
test source-5.2 {source resource files} {macOnly} {
    makeFile {return} source.file
    list [catch {source -rsrc rsrcName $sourcefile} msg] $msg
} [list 1 "Error reading the file: \"$sourcefile\"."]
test source-5.3 {source resource files} {macOnly} {
    testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return}
    set result [catch {source -rsrc rsrcName rsrc.file} msg]
    removeFile rsrc.file
    list $msg2 $result $msg
} [list ok 0 {}]
test source-5.4 {source resource files} {macOnly} {
172
173
174
175
176
177
178
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
    removeFile rsrc.file
    list $msg2 $result $msg
} [list hello 1 bad]

test source-6.1 {source is binary ok} {
    set x {}
    makeFile [list set x "a b\0c"] source.file
    source source.file
    string length $x
} 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} {
    set x {}
    makeFile [list set x "ab\32c"] source.file
    source source.file
    string length $x
} 2

# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
return



















|





|







<
<
<
<
<
<
<
<
<
<
<
<
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193












    removeFile rsrc.file
    list $msg2 $result $msg
} [list hello 1 bad]

test source-6.1 {source is binary ok} {
    set x {}
    makeFile [list set x "a b\0c"] source.file
    source $sourcefile
    string length $x
} 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} {
    set x {}
    makeFile [list set x "ab\32c"] source.file
    source $sourcefile
    string length $x
} 2

# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
return












Changes to tests/stack.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
# Tests that the stack size is big enough for the application.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stack.test,v 1.11.4.2 2002/06/10 05:33:17 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Note that a failure in this test results in a crash of the executable.
# In order to avoid that, we do a basic check of the current stacksize.
# This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh).

# This doesn't catch all cases, for example threads of lower stacksize
# can still squeak through.  A core check is really needed. -- JH

if {[string equal $::tcl_platform(platform) "unix"]} {
    set stackSize [exec /bin/sh -c "ulimit -s"]
    if {[string is integer $stackSize] && ($stackSize < 2400)} {
        puts stderr "WARNING: the default application stacksize of $stackSize\
                may cause Tcl to\ncrash due to stack overflow before the\
                recursion limit is reached.\nA minimum stacksize of 2400\
                kbytes is recommended.\nSkipping infinite recursion test."
        set ::tcltest::testConstraints(minStack2400) 0
    } else {
        set ::tcltest::testConstraints(minStack2400) 1
    }
} else {
    set ::tcltest::testConstraints(minStack2400) 1
}

test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
    proc recurse {} { return [recurse] }
    catch {recurse} rv
    rename recurse {}
    set rv
} {too many nested calls to Tcl_Eval (infinite loop?)}

test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
    # do this in a slave to not mess with parent
    set slave stack-2.1
    interp create $slave
    $slave eval { interp alias {} unknown {} notaknownproc }
    set msg [$slave eval { catch {foo} msg ; set msg }]
    interp delete $slave
    set msg
} {too many nested calls to AliasObjCmd (infinite loop using alias?)}

# cleanup
::tcltest::cleanupTests
return











|


|

















|

|


|







|









|




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
# Tests that the stack size is big enough for the application.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stack.test,v 1.11.4.3 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Note that a failure in this test results in a crash of the executable.
# In order to avoid that, we do a basic check of the current stacksize.
# This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh).

# This doesn't catch all cases, for example threads of lower stacksize
# can still squeak through.  A core check is really needed. -- JH

if {[string equal $::tcl_platform(platform) "unix"]} {
    set stackSize [exec /bin/sh -c "ulimit -s"]
    if {[string is integer $stackSize] && ($stackSize < 2400)} {
        puts stderr "WARNING: the default application stacksize of $stackSize\
                may cause Tcl to\ncrash due to stack overflow before the\
                recursion limit is reached.\nA minimum stacksize of 2400\
                kbytes is recommended.\nSkipping infinite recursion test."
        ::tcltest::testConstraint minStack2400 0
    } else {
        ::tcltest::testConstraint minStack2400 1
    }
} else {
    ::tcltest::testConstraint minStack2400 1
}

test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
    proc recurse {} { return [recurse] }
    catch {recurse} rv
    rename recurse {}
    set rv
} {too many nested evaluations (infinite loop?)}

test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
    # do this in a slave to not mess with parent
    set slave stack-2.1
    interp create $slave
    $slave eval { interp alias {} unknown {} notaknownproc }
    set msg [$slave eval { catch {foo} msg ; set msg }]
    interp delete $slave
    set msg
} {too many nested evaluations (infinite loop?)}

# cleanup
::tcltest::cleanupTests
return
Changes to tests/subst.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  subst
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: subst.test,v 1.9.8.1 2002/06/10 05:33:17 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test subst-1.1 {basics} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  subst
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: subst.test,v 1.9.8.2 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test subst-1.1 {basics} {
90
91
92
93
94
95
96














97
98
99
100
101
102
103
    set a 0
    list [catch {subst {0[set a 1}} msg] $a $msg 
} {1 0 {missing close-bracket}}
test subst-5.7 {command substitutions} {
    set a 0
    list [catch {subst {0[set a 1; set a 2}} msg] $a $msg 
} {1 1 {missing close-bracket}}















test subst-6.1 {clear the result after command substitution} {
    catch {unset a}
    list [catch {subst {[concat foo] $a}} msg] $msg
} {1 {can't read "a": no such variable}}

test subst-7.1 {switches} {







>
>
>
>
>
>
>
>
>
>
>
>
>
>







90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
    set a 0
    list [catch {subst {0[set a 1}} msg] $a $msg 
} {1 0 {missing close-bracket}}
test subst-5.7 {command substitutions} {
    set a 0
    list [catch {subst {0[set a 1; set a 2}} msg] $a $msg 
} {1 1 {missing close-bracket}}

# repeat the tests above simulating cmd line input
test subst-5.8 {command substitutions} {
    set script {[subst {[set a 1}]}
    list [catch {exec [info nameofexecutable] << $script} msg] $msg 
} {1 {missing close-bracket}}
test subst-5.9 {command substitutions} {
    set script {[subst {0[set a 1}]}
    list [catch {exec [info nameofexecutable] << $script} msg] $msg 
} {1 {missing close-bracket}}
test subst-5.10 {command substitutions} {
    set script {[subst {0[set a 1; set a 2}]}
    list [catch {exec [info nameofexecutable] << $script} msg] $msg 
} {1 {missing close-bracket}}

test subst-6.1 {clear the result after command substitution} {
    catch {unset a}
    list [catch {subst {[concat foo] $a}} msg] $msg
} {1 {can't read "a": no such variable}}

test subst-7.1 {switches} {
Changes to tests/tcltest.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation. 
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.16.8.2 2002/06/10 05:33:17 wolfsuit Exp $

# Note that there are several places where the value of 
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself.  Ditto on things like [verbose].
#
# It would be better to have the -body of the tests run the tcltest
# commands in a slave interp so the [test] being tested would not
# interfere with the [test] doing the testing.  Use of a slave
# interp might also be able to replace the [exec] of child processes
# that make this test file take so long to complete.
#
# Anyone reading this who has some time, a patch making that change
# would be welcome.
#

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}









|









|
<
<
<
<
<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19





20
21
22
23
24
25
26
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation. 
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.test,v 1.16.8.3 2002/08/20 20:25:29 das Exp $

# Note that there are several places where the value of 
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
# testing to run the test itself.  Ditto on things like [verbose].
#
# It would be better to have the -body of the tests run the tcltest
# commands in a slave interp so the [test] being tested would not
# interfere with the [test] doing the testing.  





#

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}

47
48
49
50
51
52
53


54

55
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
    test d-1.0 {test d} {
	error "foo" foo 9
    } {}
    tcltest::cleanupTests
    exit
} test.tcl



# test -help

test tcltest-1.1 {tcltest -help} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -help} msg]
    set result [catch {runCmd $cmd}]
    list $result [regexp Usage $msg]
} {1 1} 
test tcltest-1.2 {tcltest -help -something} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -help -something} msg]
    list $result [regexp Usage $msg]
} {1 1}
test tcltest-1.3 {tcltest -h} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -h} msg]
    list $result [regexp Usage $msg]
} {0 0} 

# -verbose, implicit & explicit testing of [verbose]




































test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -verbose 'b'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -verbose 'p'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -verbose 's'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -verbose 'ps'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -verbose 'psb'} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}

test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -verbose "pass skip body"} msg]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}

test tcltest-2.6 {tcltest -verbose 't'}  {
    -constraints {unixOrPc} 
    -body {
	set result [catch {exec [interpreter] test.tcl -verbose 't'} msg]
	list $result $msg
    }
    -result {^0 .*a-1.0 start.*b-1.0 start}
    -match regexp
}

test tcltest-2.6a {tcltest -verbose 'start'}  {
    -constraints {unixOrPc} 
    -body {
	set result [catch {exec [interpreter] test.tcl -verbose start} msg]
	list $result $msg
    }
    -result {^0 .*a-1.0 start.*b-1.0 start}
    -match regexp
}

test tcltest-2.7 {tcltest::verbose}  {
    -body {
	set oldVerbosity [verbose]
	verbose bar
	set currentVerbosity [verbose]
	verbose foo
	set newVerbosity [verbose]
	verbose $oldVerbosity
	list $currentVerbosity $newVerbosity 
    }
    -result {{body a r} {f o o}}
}

test tcltest-2.8 {tcltest -verbose 'error'} {
    -constraints {unixOrPc}
    -body {
	set result [catch {exec [interpreter] test.tcl -verbose error} msg]
	list $result $msg
    }
    -result {errorInfo: foo.*errorCode: 9}
    -match regexp
}
# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -match a* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -match b* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -match c* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -match {a* b*} -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 1 0 1}

test tcltest-3.5 {tcltest::match}  {
    -body {
	set oldMatch [match]
	match foo
	set currentMatch [match]
	match bar
	set newMatch [match]
	match $oldMatch
	list $currentMatch $newMatch
    }
    -result {foo bar}
}
	
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -skip a* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -skip b* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -skip c* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -skip {a* b*} -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -match {a* b*} -skip b* -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}

test tcltest-4.6 {tcltest::skip} {
    -body {
	set oldSkip [skip]
	skip foo
	set currentSkip [skip]
	skip bar
	set newSkip [skip]
	skip $oldSkip
	list $currentSkip $newSkip
    }
    -result {foo bar}
}

# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -constraints knownBug -verbose 'ps'} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
    set result [catch {exec [interpreter] test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1} msg]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}

test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)}  {
    -body {
	set r1 [testConstraint tcltestFakeConstraint]







>
>

>
|

<


|



|


|


>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|





|





|





|





|





|






|








|









|
















|





|







|




|




|




|



















|




|




|




|




|




















|




|







42
43
44
45
46
47
48
49
50
51
52
53
54

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
    test d-1.0 {test d} {
	error "foo" foo 9
    } {}
    tcltest::cleanupTests
    exit
} test.tcl

cd [temporaryDirectory]
testConstraint exec [llength [info commands exec]]
# test -help
# Child processes because -help [exit]s.
test tcltest-1.1 {tcltest -help} {exec} {
    set result [catch {exec [interpreter] test.tcl -help} msg]

    list $result [regexp Usage $msg]
} {1 1} 
test tcltest-1.2 {tcltest -help -something} {exec} {
    set result [catch {exec [interpreter] test.tcl -help -something} msg]
    list $result [regexp Usage $msg]
} {1 1}
test tcltest-1.3 {tcltest -h} {exec} {
    set result [catch {exec [interpreter] test.tcl -h} msg]
    list $result [regexp Usage $msg]
} {1 0} 

# -verbose, implicit & explicit testing of [verbose]
proc slave {msgVar args} {
    upvar 1 $msgVar msg

    interp create [namespace current]::i
    # Fake the slave interp into dumping output to a file
    i eval {namespace eval ::tcltest {}}
    i eval "set tcltest::outputChannel \[open [makeFile {} output] w]"
    i eval "set tcltest::errorChannel \[open [makeFile {} error] w]"
    i eval [list set argv0 [lindex $args 0]]
    i eval [list set argv [lrange $args 1 end]]
    i eval [list package ifneeded tcltest [package provide tcltest] \
	    [package ifneeded tcltest [package provide tcltest]]]
    i eval {proc exit args {}}

    # Need to capture output in msg

    set code [catch {i eval {source $argv0}} foo]
if $code {
#puts "$code: $foo\n$::errorInfo"
}
    i eval {close $tcltest::outputChannel}
    interp delete [namespace current]::i
    set f [open [file join [temporaryDirectory] output]]
    set msg [read -nonewline $f]
    close $f
    set f [open [file join [temporaryDirectory] error]]
    set err [read -nonewline $f]
    close $f
    if {[string length $err]} {
	set code 1
	append msg \n$err
    }
    return $code

#    return [catch {uplevel 1 [linsert $args 0  exec [interpreter]]} msg]
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
    set result [slave msg test.tcl]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
    set result [slave msg test.tcl -verbose 'b']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
    set result [slave msg test.tcl -verbose 'p']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
    set result [slave msg test.tcl -verbose 's']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
    set result [slave msg test.tcl -verbose 'ps']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
    set result [slave msg test.tcl -verbose 'psb']
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}

test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
    set result [slave msg test.tcl -verbose "pass skip body"]
    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
	    [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}

test tcltest-2.6 {tcltest -verbose 't'}  {
    -constraints {unixOrPc} 
    -body {
	set result [slave msg test.tcl -verbose 't']
	list $result $msg
    }
    -result {^0 .*a-1.0 start.*b-1.0 start}
    -match regexp
}

test tcltest-2.6a {tcltest -verbose 'start'}  {
    -constraints {unixOrPc} 
    -body {
	set result [slave msg test.tcl -verbose start]
	list $result $msg
    }
    -result {^0 .*a-1.0 start.*b-1.0 start}
    -match regexp
}

test tcltest-2.7 {tcltest::verbose}  {
    -body {
	set oldVerbosity [verbose]
	verbose bar
	set currentVerbosity [verbose]
	verbose foo
	set newVerbosity [verbose]
	verbose $oldVerbosity
	list $currentVerbosity $newVerbosity 
    }
    -result {body {}}
}

test tcltest-2.8 {tcltest -verbose 'error'} {
    -constraints {unixOrPc}
    -body {
	set result [slave msg test.tcl -verbose error]
	list $result $msg
    }
    -result {errorInfo: foo.*errorCode: 9}
    -match regexp
}
# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
    set result [slave msg test.tcl -match a* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
    set result [slave msg test.tcl -match b* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
    set result [slave msg test.tcl -match c* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
    set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 1 0 1}

test tcltest-3.5 {tcltest::match}  {
    -body {
	set oldMatch [match]
	match foo
	set currentMatch [match]
	match bar
	set newMatch [match]
	match $oldMatch
	list $currentMatch $newMatch
    }
    -result {foo bar}
}
	
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
    set result [slave msg test.tcl -skip a* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
    set result [slave msg test.tcl -skip b* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
    set result [slave msg test.tcl -skip c* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
    set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
    set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}

test tcltest-4.6 {tcltest::skip} {
    -body {
	set oldSkip [skip]
	skip foo
	set currentSkip [skip]
	skip bar
	set newSkip [skip]
	skip $oldSkip
	list $currentSkip $newSkip
    }
    -result {foo bar}
}

# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
    set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
    set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
	    [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}

test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)}  {
    -body {
	set r1 [testConstraint tcltestFakeConstraint]
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
#}

test tcltest-5.5 {InitConstraints: list of built-in constraints} \
	-constraints {!singleTestInterp} \
	-setup {tcltest::InitConstraints} \
	-body { lsort [array names ::tcltest::testConstraints] } \
	-result [lsort {
    95 98 asyncPipeClose eformat emptyTest hasIsoLocale interactive knownBug
    mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles nonPortable
    notRoot nt pc pcCrash pcOnly root singleTestInterp socket stdio tempNotMac
    tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs unixOnly unixOrPc
    unixOrWin userInteraction win winCrash winOnly
}]

# Removed this broken test.  Its usage of [limitConstraints] was not
# in agreement with the documentation.  [limitConstraints] is supposed
# to take an optional boolean argument, and "knownBug" ain't no boolean!
#test tcltest-5.6 {tcltest::limitConstraints} {
#    -setup {







|
|
|
|
|







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
#}

test tcltest-5.5 {InitConstraints: list of built-in constraints} \
	-constraints {!singleTestInterp} \
	-setup {tcltest::InitConstraints} \
	-body { lsort [array names ::tcltest::testConstraints] } \
	-result [lsort {
    95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
    knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
    nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
    stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
    unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
}]

# Removed this broken test.  Its usage of [limitConstraints] was not
# in agreement with the documentation.  [limitConstraints] is supposed
# to take an optional boolean argument, and "knownBug" ain't no boolean!
#test tcltest-5.6 {tcltest::limitConstraints} {
#    -setup {
322
323
324
325
326
327
328
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
    ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
    exit
} printerror.tcl]

test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
    -constraints unixOrPc
    -body {
	catch {exec [interpreter] $printerror} msg
	return $msg
    }
    -result {a test.*a really}
    -match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
    catch {exec [interpreter] printerror.tcl -outfile a.tmp} msg
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp] 
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
    catch {exec [interpreter] printerror.tcl -errfile a.tmp} msg
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
    catch {exec [interpreter] printerror.tcl -outfile a.tmp -errfile b.tmp} msg
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" b.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 \
	    [file exists a.tmp] [file delete a.tmp] \
	    [file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}







|






|






|






|







355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
    ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
    exit
} printerror.tcl]

test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
    -constraints unixOrPc
    -body {
	slave msg $printerror
	return $msg
    }
    -result {a test.*a really}
    -match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
    slave msg $printerror -outfile a.tmp
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp] 
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
    slave msg $printerror -errfile a.tmp
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" a.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
    slave msg printerror.tcl -outfile a.tmp -errfile b.tmp
    set result1 [catch {exec grep "a test" a.tmp}]
    set result2 [catch {exec grep "a really" b.tmp}]
    list [regexp "a test" $msg] [regexp "a really" $msg] \
	    $result1 $result2 \
	    [file exists a.tmp] [file delete a.tmp] \
	    [file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}
424
425
426
427
428
429
430



431
432
433
434
435
436
437
    -match regexp
    -cleanup {
	outputFile $of
    }
}

# -debug, [debug]



test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 0} msg
    regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
    list [regexp userSpecifiedSkip $msg] \







>
>
>







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
    -match regexp
    -cleanup {
	outputFile $of
    }
}

# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# slave interp
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 0} msg
    regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
    catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
    list [regexp userSpecifiedSkip $msg] \
471
472
473
474
475
476
477
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
}

# directory tests

makeFile {
    package require tcltest
    tcltest::makeFile {} a.tmp
    puts "testdir: [tcltest::testsDirectory]"
    exit
} a.tcl

makeFile {} thisdirectoryisafile  

set normaldirectory [makeDirectory normaldirectory]
if {$::tcl_platform(platform) == "macintosh"} {
set normaldirectory [file normalize $normaldirectory]
}

# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    exec [interpreter] a.tcl -tmpdir thisdirectorydoesnotexist
    list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
	    [file delete -force thisdirectorydoesnotexist] 
} {1 {}}
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
    -constraints unixOrPc
    -body {
	catch {exec [interpreter] a.tcl -tmpdir thisdirectoryisafile} msg
	# The join is necessary because the message can be split on multiple
	# lines 
	join $msg
    }
    -result {not a directory}
    -match regexp
}

# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]

makeDirectory notreadable
makeDirectory notwriteable

switch $tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {
	catch {file attributes $notWriteableDir -readonly 1}
    }
}

test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
    catch {exec [interpreter] a.tcl -tmpdir $notReadableDir} msg 
    # The join is necessary because the message can be split on multiple lines
    list [regexp {not readable} [join $msg]]
} {1}

test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
    catch {exec [interpreter] a.tcl -tmpdir $notWriteableDir} msg
    # The join is necessary because the message can be split on multiple lines
    list [regexp {not writeable} [join $msg]]
} {1}

test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
    catch {exec [interpreter] a.tcl -tmpdir $normaldirectory} msg
    # The join is necessary because the message can be split on multiple lines
    list [file exists [file join $normaldirectory a.tmp]] \
	    [file delete [file join $normaldirectory a.tmp]] 
} {1 {}}   


set current [pwd]
test tcltest-8.6 {temporaryDirectory}  {
    -setup {
	set old $::tcltest::temporaryDirectory
	set ::tcltest::temporaryDirectory $normaldirectory
    }
    -body {
	set f1 [temporaryDirectory]
	set f2 [temporaryDirectory $current]
	set f3 [temporaryDirectory]
	list $f1 $f2 $f3
    }
    -result "[list $normaldirectory $current $current]"
    -cleanup {
	set ::tcltest::temporaryDirectory $old
    }
}

test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
    set old $::tcltest::temporaryDirectory
    set ::tcltest::temporaryDirectory $normaldirectory
} -body {
    set f1 [temporaryDirectory]
    set f2 [temporaryDirectory $current]
    set f3 [temporaryDirectory]
    list $f1 $f2 $f3
} -cleanup {
    set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory $current $current]


# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    catch {exec [interpreter] a.tcl -testdir thisdirectorydoesnotexist}  msg
    list [regexp "does not exist" [join $msg]]
} {1}

test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
    catch {exec [interpreter] a.tcl -testdir thisdirectoryisafile} msg
    # The join is necessary because the message can be split on multiple lines
    list [regexp "not a directory" [join $msg]] 
} {1}

test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
    catch {exec [interpreter] a.tcl -testdir $notReadableDir} msg 
    # The join is necessary because the message can be split on multiple lines
    list [regexp {not readable} [join $msg]]
} {1}


test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
    catch {exec [interpreter] a.tcl -testdir $normaldirectory} msg
    # The join is necessary because the message can be split on multiple lines
    list [string first "testdir: $normaldirectory" [join $msg]] \
	    [file exists [file join [temporaryDirectory] a.tmp]] \
	    [file delete [file join [temporaryDirectory] a.tmp]] 
} {0 1 {}} 



test tcltest-8.14 {testsDirectory} {
    -setup {
	set old $::tcltest::testsDirectory
	set current [pwd]
	set ::tcltest::testsDirectory $normaldirectory
    }
    -body {
	set f1 [testsDirectory]
	set f2 [testsDirectory $current]
	set f3 [testsDirectory]
	list $f1 $f2 $f3







|













|






|
<
<
|

|
|




















|
<
|



|
<
|



|




|

<







|



|










|




|

>



|
|



|
<
|



|
<
|




|





>

>



<







507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535


536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560

561
562
563
564
565

566
567
568
569
570
571
572
573
574
575
576

577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615

616
617
618
619
620

621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637

638
639
640
641
642
643
644
}

# directory tests

makeFile {
    package require tcltest
    tcltest::makeFile {} a.tmp
    puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
    exit
} a.tcl

makeFile {} thisdirectoryisafile  

set normaldirectory [makeDirectory normaldirectory]
if {$::tcl_platform(platform) == "macintosh"} {
set normaldirectory [file normalize $normaldirectory]
}

# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    slave msg a.tcl -tmpdir thisdirectorydoesnotexist
    list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
	    [file delete -force thisdirectorydoesnotexist] 
} {1 {}}
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
    -constraints unixOrPc
    -body {
	slave msg a.tcl -tmpdir thisdirectoryisafile


	set msg
    }
    -result {*not a directory*}
    -match glob
}

# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]

makeDirectory notreadable
makeDirectory notwriteable

switch $tcl_platform(platform) {
    "unix" {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {
	catch {file attributes $notWriteableDir -readonly 1}
    }
}

test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
    slave msg a.tcl -tmpdir $notReadableDir 

    string match {*not readable*} $msg
} {1}

test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
    slave msg a.tcl -tmpdir $notWriteableDir

    string match {*not writeable*} $msg
} {1}

test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
    slave msg a.tcl -tmpdir $normaldirectory
    # The join is necessary because the message can be split on multiple lines
    list [file exists [file join $normaldirectory a.tmp]] \
	    [file delete [file join $normaldirectory a.tmp]] 
} {1 {}}   
cd [workingDirectory]


test tcltest-8.6 {temporaryDirectory}  {
    -setup {
	set old $::tcltest::temporaryDirectory
	set ::tcltest::temporaryDirectory $normaldirectory
    }
    -body {
	set f1 [temporaryDirectory]
	set f2 [temporaryDirectory [workingDirectory]]
	set f3 [temporaryDirectory]
	list $f1 $f2 $f3
    }
    -result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
    -cleanup {
	set ::tcltest::temporaryDirectory $old
    }
}

test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
    set old $::tcltest::temporaryDirectory
    set ::tcltest::temporaryDirectory $normaldirectory
} -body {
    set f1 [temporaryDirectory]
    set f2 [temporaryDirectory [workingDirectory]]
    set f3 [temporaryDirectory]
    list $f1 $f2 $f3
} -cleanup {
    set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]

cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
    file delete -force thisdirectorydoesnotexist
    slave msg a.tcl -testdir thisdirectorydoesnotexist
    string match "*does not exist*" $msg
} {1}

test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
    slave msg a.tcl -testdir thisdirectoryisafile

    string match "*not a directory*" $msg 
} {1}

test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
    slave msg a.tcl -testdir $notReadableDir 

    string match {*not readable*} $msg
} {1}


test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
    slave msg a.tcl -testdir $normaldirectory
    # The join is necessary because the message can be split on multiple lines
    list [string first "testdir: $normaldirectory" [join $msg]] \
	    [file exists [file join [temporaryDirectory] a.tmp]] \
	    [file delete [file join [temporaryDirectory] a.tmp]] 
} {0 1 {}} 
cd [workingDirectory]

set current [pwd]
test tcltest-8.14 {testsDirectory} {
    -setup {
	set old $::tcltest::testsDirectory

	set ::tcltest::testsDirectory $normaldirectory
    }
    -body {
	set f1 [testsDirectory]
	set f2 [testsDirectory $current]
	set f3 [testsDirectory]
	list $f1 $f2 $f3
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
    }
}

file delete -force $notReadableDir $notWriteableDir

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} {unixOrPc} {
    catch {exec [interpreter] \
	    [file join [testsDirectory] all.tcl] -file a*.test} msg
    list [regexp assocd\.test $msg]
} {1}
test tcltest-9.2 {-file a*.tcl} {unixOrPc} {
    catch {exec [interpreter] \
	    [file join [testsDirectory] all.tcl] \
	    -file a*.test -notfile assocd*} msg
    list [regexp assocd\.test $msg]
} {0}

test tcltest-9.3 {matchFiles}  {
    -body {
	set old [matchFiles]
	matchFiles foo







<
|



<
|
|







688
689
690
691
692
693
694

695
696
697
698

699
700
701
702
703
704
705
706
707
    }
}

file delete -force $notReadableDir $notWriteableDir

# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} {unixOrPc} {

    slave msg [file join [testsDirectory] all.tcl] -file a*.test
    list [regexp assocd\.test $msg]
} {1}
test tcltest-9.2 {-file a*.tcl} {unixOrPc} {

    slave msg [file join [testsDirectory] all.tcl] \
	    -file a*.test -notfile assocd*
    list [regexp assocd\.test $msg]
} {0}

test tcltest-9.3 {matchFiles}  {
    -body {
	set old [matchFiles]
	matchFiles foo
706
707
708
709
710
711
712

713
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
	set f [open core w]
	close $f
    } {}
    ::tcltest::cleanupTests
    return
} makecore.tcl


test tcltest-10.1 {-preservecore 0} {unixOrPc} {
    catch {exec [interpreter] makecore.tcl -preservecore 0} msg
    file delete core
    regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
    catch {exec [interpreter] makecore.tcl -preservecore 1} msg
    file delete core
    regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
    catch {exec [interpreter] makecore.tcl -preservecore 2} msg
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
    catch {exec [interpreter] makecore.tcl -preservecore 3} msg
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}




test tcltest-10.5 {preserveCore} {
    -body {
	set old [preserveCore]
	set result [preserveCore foo]
	set result2 [preserveCore]
	preserveCore $old
	list $result $result2
    }

    -result {foo foo}

}

# -load, -loadfile, [loadScript], [loadFile]
set loadfile [makeFile { 
    package require tcltest

    puts $::tcltest::loadScript
    exit

} load.tcl]

test tcltest-12.1 {-load xxx} {unixOrPc} {
    catch {exec [interpreter] load.tcl -load xxx} msg
    set msg
} {xxx}


test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
    catch {exec [interpreter] load.tcl -debug 2 -loadfile load.tcl} msg
    list \
	    [regexp {tcltest} [join [list $msg] [split $msg \n]]] \
	    [regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}








>

|




|




|





|





>
>
>
|
|
|
|
|
|
|
<
>
|
>
|
<

|

>
|

>
|


|



>







735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775

776
777
778
779

780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
	set f [open core w]
	close $f
    } {}
    ::tcltest::cleanupTests
    return
} makecore.tcl

cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
    slave msg makecore.tcl -preservecore 0
    file delete core
    regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
    slave msg makecore.tcl -preservecore 1
    file delete core
    regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
    slave msg makecore.tcl -preservecore 2
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
    slave msg makecore.tcl -preservecore 3
    file delete core
    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
	    [regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}

# Removing this test.  It makes no sense to test the ability of
# [preserveCore] to accept an invalid value that will cause errors
# in other parts of tcltest's operation.
#test tcltest-10.5 {preserveCore} {
#    -body {
#	set old [preserveCore]
#	set result [preserveCore foo]
#	set result2 [preserveCore]
#	preserveCore $old
#	list $result $result2

#    }
#    -result {foo foo}
#}


# -load, -loadfile, [loadScript], [loadFile]
set contents { 
    package require tcltest
    namespace import tcltest::*
    puts [outputChannel] $::tcltest::loadScript
    exit
} 
set loadfile [makeFile $contents load.tcl]

test tcltest-12.1 {-load xxx} {unixOrPc} {
    slave msg load.tcl -load xxx
    set msg
} {xxx}

# Using child process because of -debug usage.
test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
    catch {exec [interpreter] load.tcl -debug 2 -loadfile load.tcl} msg
    list \
	    [regexp {tcltest} [join [list $msg] [split $msg \n]]] \
	    [regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}

789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
	set f1 [loadScript]
	set f2 [loadFile]
	set f3 [loadFile load.tcl]
	set f4 [loadScript]
	set f5 [loadFile]
	list $f1 $f2 $f3 $f4 $f5
    }
    -result "[list {} {} $loadfile { 
    package require tcltest
    puts $::tcltest::loadScript
    exit
} $loadfile]\n"
    -cleanup {
	set ::tcltest::loadScript $olds
	set ::tcltest::loadFile $oldf
    }
}

# [interpreter]







|
<
<
<
<







825
826
827
828
829
830
831
832




833
834
835
836
837
838
839
	set f1 [loadScript]
	set f2 [loadFile]
	set f3 [loadFile load.tcl]
	set f4 [loadScript]
	set f5 [loadFile]
	list $f1 $f2 $f3 $f4 $f5
    }
    -result "[list {} {} $loadfile $contents $loadfile]\n"




    -cleanup {
	set ::tcltest::loadScript $olds
	set ::tcltest::loadFile $oldf
    }
}

# [interpreter]
834
835
836
837
838
839
840

841
842
843
844
845

846
847
848
849
850
851
852
853
854

855
856
857
858
859
860
861

set allfile [makeFile {
    package require tcltest
    namespace import tcltest::*
    testsDirectory [file join [temporaryDirectory] singleprocdir]
    runAllTests
} [file join singleprocdir all-single.tcl]]


test tcltest-14.1 {-singleproc - single process} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] $allfile -singleproc 0

    }
    -result {Test file error: can't unset .foo.: no such variable}
    -match regexp
}

test tcltest-14.2 {-singleproc - multiple process} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] $allfile -singleproc 1

    }
    -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
    -match regexp
}

test tcltest-14.3 {singleProcess} {
    -setup {







>




|
>








|
>







866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896

set allfile [makeFile {
    package require tcltest
    namespace import tcltest::*
    testsDirectory [file join [temporaryDirectory] singleprocdir]
    runAllTests
} [file join singleprocdir all-single.tcl]]
cd [workingDirectory]

test tcltest-14.1 {-singleproc - single process} {
    -constraints {unixOrPc}
    -body {
	slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
	set msg
    }
    -result {Test file error: can't unset .foo.: no such variable}
    -match regexp
}

test tcltest-14.2 {-singleproc - multiple process} {
    -constraints {unixOrPc}
    -body {
	slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
	set msg
    }
    -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
    -match regexp
}

test tcltest-14.3 {singleProcess} {
    -setup {
907
908
909
910
911
912
913

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
    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
    runAllTests
} [file join dirtestdir dirtestdir2.3 all.tcl]

test tcltest-15.1 {basic directory walking} {
    -constraints {unixOrPc}
    -body {

	exec [interpreter] [file join [temporaryDirectory] dirtestdir all.tcl]



    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3}
}

test tcltest-15.2 {-asidefromdir} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-asidefromdir dirtestdir2.3



    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error:  No test files remain after applying your match and skip patterns!
Error:  No test files remain after applying your match and skip patterns!
Error:  No test files remain after applying your match and skip patterns!$}
}

test tcltest-15.3 {-relateddir, non-existent dir} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-relateddir [file join [temporaryDirectory] dirtestdir0]



    }
    -returnCodes 1
    -match regexp
    -result {[^~]|dirtestdir[^2]}
}

test tcltest-15.4 {-relateddir, subdir} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-relateddir dirtestdir2.1


    }
    -returnCodes 1
    -match regexp
    -result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-relateddir "dirtestdir2.1 dirtestdir2.2" \
		-asidefromdir dirtestdir2.2



    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir2.[^23]}
}

test tcltest-15.6 {matchDirectories} {







>
|
>
>
>









|

|
>
>
>












|

|
>
>
>









|

|
>
>








|


|
>
>
>







942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
    runAllTests
} [file join dirtestdir dirtestdir2.3 all.tcl]

test tcltest-15.1 {basic directory walking} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3}
}

test tcltest-15.2 {-asidefromdir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-asidefromdir dirtestdir2.3 \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error:  No test files remain after applying your match and skip patterns!
Error:  No test files remain after applying your match and skip patterns!
Error:  No test files remain after applying your match and skip patterns!$}
}

test tcltest-15.3 {-relateddir, non-existent dir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-relateddir [file join [temporaryDirectory] dirtestdir0] \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -returnCodes 1
    -match regexp
    -result {[^~]|dirtestdir[^2]}
}

test tcltest-15.4 {-relateddir, subdir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -returnCodes 1
    -match regexp
    -result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
    -constraints {unixOrPc}
    -body {
	if {[slave msg \
		[file join [temporaryDirectory] dirtestdir all.tcl] \
		-relateddir "dirtestdir2.1 dirtestdir2.2" \
		-asidefromdir dirtestdir2.2 \
		-tmpdir [temporaryDirectory]] == 1} {
	    error $msg
	}
    }
    -match regexp
    -returnCodes 1
    -result {Tests located in:.*dirtestdir2.[^23]}
}

test tcltest-15.6 {matchDirectories} {
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
	set ::tcltest::skipDirectories $old
    }
    -result {{} foo foo}
}

# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} {
    -constraints {unixOrPc}
    -setup {
	if {[info exists ::env(TCLTEST_OPTIONS)]} {
	    set oldoptions $::env(TCLTEST_OPTIONS)
	    unset ::env(TCLTEST_OPTIONS)
	} else {
	    set oldoptions none
	}







|







1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
	set ::tcltest::skipDirectories $old
    }
    -result {{} foo foo}
}

# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} {
    -constraints {unixOrPc singleTestInterp}
    -setup {
	if {[info exists ::env(TCLTEST_OPTIONS)]} {
	    set oldoptions $::env(TCLTEST_OPTIONS)
	    unset ::env(TCLTEST_OPTIONS)
	} else {
	    set oldoptions none
	}
1035
1036
1037
1038
1039
1040
1041

1042
1043
1044
1045
1046
1047
1048

1049
1050
1051





1052
1053
1054
1055
1056
1057
1058
    -result {^$}
    -match regexp
    -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
}

# Begin testing of tcltest procs ...


# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
    set result [catch {exec [interpreter] printerror.tcl} msg]
    list $result [regexp "Error:  a really short string" $msg] \
	    [regexp "     \"quotes\"" $msg] [regexp "    \"Path" $msg] \
	    [regexp "    \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}


# test::test
test tcltest-21.0 {name and desc but no args specified} -body {





   test tcltest-21.0.0 bar
} -result {}

test tcltest-21.1 {expect with glob} {
    -body {
	list a b c d e
    }







>


|




>


|
>
>
>
>
>







1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
    -result {^$}
    -match regexp
    -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
}

# Begin testing of tcltest procs ...

cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
    set result [slave msg printerror.tcl]
    list $result [regexp "Error:  a really short string" $msg] \
	    [regexp "     \"quotes\"" $msg] [regexp "    \"Path" $msg] \
	    [regexp "    \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}
cd [workingDirectory]

# test::test
test tcltest-21.0 {name and desc but no args specified} -setup {
    set v [verbose]
} -cleanup {
    verbose $v
} -body {
   verbose {}
   test tcltest-21.0.0 bar
} -result {}

test tcltest-21.1 {expect with glob} {
    -body {
	list a b c d e
    }
1083
1084
1085
1086
1087
1088
1089

1090
1091

1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105

test tcltest-21.4 {test command with cleanup failure} {
    -setup {
	if {[info exists foo]} {
	    unset foo
	}
	set fail $::tcltest::currentFailure

    }
    -body {

	test tcltest-21.4.0 {foo-1} {
	    -cleanup {unset foo}
	}
    }
    -result {^$}
    -match regexp
    -cleanup {set ::tcltest::currentFailure $fail}
    -output "Test cleanup failed:.*can't unset \"foo\": no such variable"
}

test tcltest-21.5 {test command with setup failure} {
    -setup {
	if {[info exists foo]} {
	    unset foo







>


>






|







1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164

test tcltest-21.4 {test command with cleanup failure} {
    -setup {
	if {[info exists foo]} {
	    unset foo
	}
	set fail $::tcltest::currentFailure
	set v [verbose]
    }
    -body {
	verbose {}
	test tcltest-21.4.0 {foo-1} {
	    -cleanup {unset foo}
	}
    }
    -result {^$}
    -match regexp
    -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
    -output "Test cleanup failed:.*can't unset \"foo\": no such variable"
}

test tcltest-21.5 {test command with setup failure} {
    -setup {
	if {[info exists foo]} {
	    unset foo
1114
1115
1116
1117
1118
1119
1120
1121
1122

1123
1124
1125
1126
1127
1128
1129
    -result {^$}
    -match regexp
    -cleanup {set ::tcltest::currentFailure $fail}
    -output "Test setup failed:.*can't unset \"foo\": no such variable"
}

test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
    -setup {set fail $::tcltest::currentFailure}
    -body {

	test tcltest-21.6.0 {foo-3} {
	    -setup {
		if {[info exists foo]} {
		    unset foo
		}
		set foo 1
		set expected 2







|

>







1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
    -result {^$}
    -match regexp
    -cleanup {set ::tcltest::currentFailure $fail}
    -output "Test setup failed:.*can't unset \"foo\": no such variable"
}

test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
    -setup {set v [verbose]; set fail $::tcltest::currentFailure}
    -body {
	verbose {}
	test tcltest-21.6.0 {foo-3} {
	    -setup {
		if {[info exists foo]} {
		    unset foo
		}
		set foo 1
		set expected 2
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
		} else {
		    puts [outputChannel] "foo is 2"
		}
	    }
	    -result {$expected}
	}
    }
    -cleanup {set ::tcltest::currentFailure $fail}
    -result {^$}
    -match regexp
    -output "foo is 2"
}

test tcltest-21.7 {test command - bad flag} {
    -setup {set fail $::tcltest::currentFailure}







|







1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
		} else {
		    puts [outputChannel] "foo is 2"
		}
	    }
	    -result {$expected}
	}
    }
    -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
    -result {^$}
    -match regexp
    -output "foo is 2"
}

test tcltest-21.7 {test command - bad flag} {
    -setup {set fail $::tcltest::currentFailure}
1186
1187
1188
1189
1190
1191
1192

1193

1194
1195

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
	-result {1}

test tcltest-21.10 {test command with cleanup failure} -setup {
    if {[info exists foo]} {
	unset foo
    }
    set fail $::tcltest::currentFailure

} -cleanup {

    set ::tcltest::currentFailure $fail
} -body {

    test 21.10.0 {foo-1} -cleanup {unset foo}
} -result {^$} -match regexp \
	-output {Test cleanup failed:.*can't unset \"foo\": no such variable}

test tcltest-21.11 {test command with setup failure} -setup {
    if {[info exists foo]} {
	unset foo
    }
    set fail $::tcltest::currentFailure
} -cleanup {set ::tcltest::currentFailure $fail} -body {
    test 21.11.0 {foo-2} -setup {unset foo}
} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp

test tcltest-21.12 {
	test command - setup occurs before cleanup & before script
} -setup {
	set fail $::tcltest::currentFailure

} -cleanup {

	set ::tcltest::currentFailure $fail
} -body {

    test 21.12.0 {foo-3} -setup {
	if {[info exists foo]} {
	    unset foo
	}
	set foo 1
	set expected 2
    }  -body {
	incr foo







>

>


>
|









|






>

>


>
|







1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
	-result {1}

test tcltest-21.10 {test command with cleanup failure} -setup {
    if {[info exists foo]} {
	unset foo
    }
    set fail $::tcltest::currentFailure
    set v [verbose]
} -cleanup {
    verbose $v
    set ::tcltest::currentFailure $fail
} -body {
    verbose {}
    test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
} -result {^$} -match regexp \
	-output {Test cleanup failed:.*can't unset \"foo\": no such variable}

test tcltest-21.11 {test command with setup failure} -setup {
    if {[info exists foo]} {
	unset foo
    }
    set fail $::tcltest::currentFailure
} -cleanup {set ::tcltest::currentFailure $fail} -body {
    test tcltest-21.11.0 {foo-2} -setup {unset foo}
} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp

test tcltest-21.12 {
	test command - setup occurs before cleanup & before script
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
} -cleanup {
	verbose $v
	set ::tcltest::currentFailure $fail
} -body {
    verbose {}
    test tcltest-21.12.0 {foo-3} -setup {
	if {[info exists foo]} {
	    unset foo
	}
	set foo 1
	set expected 2
    }  -body {
	incr foo
1253
1254
1255
1256
1257
1258
1259


1260
1261
1262

1263

1264
1265
1266
1267
1268
1269
1270
    test foo-1.1 {foo} {
	-body { return 1 }
	-result {1}
    }
    cleanupTests
} [file join alltestdir test.test]



test tcltest-22.1 {runAllTests} {
    -constraints {unixOrPc}
    -body {

	exec [interpreter] [file join [temporaryDirectory] alltestdir all.tcl] -verbose t

    }
    -match regexp
    -result "Test files exiting with errors:.*error.test.*exit.test"
}

# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
test tcltest-23.1 {makeFile} {







>
>



>
|
>







1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
    test foo-1.1 {foo} {
	-body { return 1 }
	-result {1}
    }
    cleanupTests
} [file join alltestdir test.test]

# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
    -constraints {unixOrPc}
    -body {
	exec [interpreter] \
		[file join [temporaryDirectory] alltestdir all.tcl] \
		-verbose t -tmpdir [temporaryDirectory]
    }
    -match regexp
    -result "Test files exiting with errors:.*error.test.*exit.test"
}

# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
test tcltest-23.1 {makeFile} {
1409
1410
1411
1412
1413
1414
1415
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
} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}

test tcltest-24.6 {
	customMatch: -match script that always matches
} -setup {
	customMatch [namespace current]::alwaysMatch "format 1 ;#"
	set v [verbose]
	verbose {}
} -body {

	test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
		-body {format 1} -result 0
} -cleanup {
	verbose $v
} -result {} -output {} -errorOutput {}

test tcltest-24.7 {
	customMatch: replace default -exact matching
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact "format 1 ;#"
	set v [verbose]
	verbose {}
} -body {

	test tcltest-24.7.0 {} -body {format 1} -result 0
} -cleanup {
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -result {} -output {}

test tcltest-24.9 {
	customMatch: error during match
} -setup {
	proc errorDuringMatch args {return -code error "match returned error"}
	customMatch [namespace current]::errorDuringMatch \
		[namespace code errorDuringMatch]

	set fail $::tcltest::currentFailure
} -body {

	test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
} -cleanup {

	set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*match returned error*}

test tcltest-24.10 {
	customMatch: bad return from match command
} -setup {
	proc nonBooleanReturn args {return foo}
	customMatch nonBooleanReturn [namespace code nonBooleanReturn]

	set fail $::tcltest::currentFailure
} -body {

	test tcltest-24.10.0 {} -match nonBooleanReturn
} -cleanup {

	set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*expected boolean value*}

test tcltest-24.11 {
	test: -match exact
} -body {
	set result {A B C}
} -match exact -result {A B C}

test tcltest-24.12 {
	test: -match exact	match command eval in ::, not caller namespace
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact [list string equal]
	set v [verbose]
	verbose {}
	proc string args {error {called [string] in caller namespace}}
} -body {

	test tcltest-24.12.0 {} -body {format 1} -result 1
} -cleanup {
	rename string {}
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -match exact -result {} -output {}

test tcltest-24.13 {
	test: -match exact	failure
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact [list string equal]
	set v [verbose]
	verbose {}
	set fail $::tcltest::currentFailure
} -body {

	test tcltest-24.13.0 {} -body {format 1} -result 0
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -match glob -result {} -output {*FAILED*Result was:
1*(exact matching):
0*}

test tcltest-24.14 {
	test: -match glob
} -body {
	set result {A B C}
} -match glob -result {A B*}

test tcltest-24.15 {
	test: -match glob	failure
} -setup {
	set v [verbose]
	verbose {}
	set fail $::tcltest::currentFailure
} -body {

	test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
		-result {A B* }
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(glob matching):
*}

test tcltest-24.16 {
	test: -match regexp
} -body {
	set result {A B C}
} -match regexp -result {A B.*}

test tcltest-24.17 {
	test: -match regexp	failure
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
	verbose {}
} -body {

	test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
		-result {A B.* X}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(regexp matching):
*}

test tcltest-24.18 {
	test: -match custom	forget namespace qualification
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
	verbose {}
	customMatch negative matchNegative
} -body {

	test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
		-result {A B X}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Error testing result:*}

test tcltest-24.19 {
	test: -match custom
} -setup {
	set v [verbose]
	verbose {}
	customMatch negative [namespace code matchNegative]
} -body {

	test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
		-result {A B X}
} -cleanup {
	verbose $v
} -match exact -result {} -output {}

test tcltest-24.20 {
	test: -match custom	failure
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]
	verbose {}
	customMatch negative [namespace code matchNegative]
} -body {

	test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
		-result {A B C}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(negative matching):
*}



















cleanupTests
}

namespace delete ::tcltest::test
return







<

>












<

>













>


>


>








>


>


>















<


>














<


>




















<


>




















<

>














<


>











<


>











<


>








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






1479
1480
1481
1482
1483
1484
1485

1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499

1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551

1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568

1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591

1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614

1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630

1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644

1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658

1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}

test tcltest-24.6 {
	customMatch: -match script that always matches
} -setup {
	customMatch [namespace current]::alwaysMatch "format 1 ;#"
	set v [verbose]

} -body {
	verbose {}
	test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
		-body {format 1} -result 0
} -cleanup {
	verbose $v
} -result {} -output {} -errorOutput {}

test tcltest-24.7 {
	customMatch: replace default -exact matching
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact "format 1 ;#"
	set v [verbose]

} -body {
	verbose {}
	test tcltest-24.7.0 {} -body {format 1} -result 0
} -cleanup {
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -result {} -output {}

test tcltest-24.9 {
	customMatch: error during match
} -setup {
	proc errorDuringMatch args {return -code error "match returned error"}
	customMatch [namespace current]::errorDuringMatch \
		[namespace code errorDuringMatch]
	set v [verbose]
	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
} -cleanup {
	verbose $v
	set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*match returned error*}

test tcltest-24.10 {
	customMatch: bad return from match command
} -setup {
	proc nonBooleanReturn args {return foo}
	customMatch nonBooleanReturn [namespace code nonBooleanReturn]
	set v [verbose]
	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.10.0 {} -match nonBooleanReturn
} -cleanup {
	verbose $v
	set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*expected boolean value*}

test tcltest-24.11 {
	test: -match exact
} -body {
	set result {A B C}
} -match exact -result {A B C}

test tcltest-24.12 {
	test: -match exact	match command eval in ::, not caller namespace
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact [list string equal]
	set v [verbose]

	proc string args {error {called [string] in caller namespace}}
} -body {
	verbose {}
	test tcltest-24.12.0 {} -body {format 1} -result 1
} -cleanup {
	rename string {}
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -match exact -result {} -output {}

test tcltest-24.13 {
	test: -match exact	failure
} -setup {
	set saveExactMatchScript $::tcltest::CustomMatch(exact)
	customMatch exact [list string equal]
	set v [verbose]

	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.13.0 {} -body {format 1} -result 0
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
	customMatch exact $saveExactMatchScript
	unset saveExactMatchScript
} -match glob -result {} -output {*FAILED*Result was:
1*(exact matching):
0*}

test tcltest-24.14 {
	test: -match glob
} -body {
	set result {A B C}
} -match glob -result {A B*}

test tcltest-24.15 {
	test: -match glob	failure
} -setup {
	set v [verbose]

	set fail $::tcltest::currentFailure
} -body {
	verbose {}
	test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
		-result {A B* }
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(glob matching):
*}

test tcltest-24.16 {
	test: -match regexp
} -body {
	set result {A B C}
} -match regexp -result {A B.*}

test tcltest-24.17 {
	test: -match regexp	failure
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]

} -body {
	verbose {}
	test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
		-result {A B.* X}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(regexp matching):
*}

test tcltest-24.18 {
	test: -match custom	forget namespace qualification
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]

	customMatch negative matchNegative
} -body {
	verbose {}
	test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
		-result {A B X}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Error testing result:*}

test tcltest-24.19 {
	test: -match custom
} -setup {
	set v [verbose]

	customMatch negative [namespace code matchNegative]
} -body {
	verbose {}
	test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
		-result {A B X}
} -cleanup {
	verbose $v
} -match exact -result {} -output {}

test tcltest-24.20 {
	test: -match custom	failure
} -setup {
	set fail $::tcltest::currentFailure
	set v [verbose]

	customMatch negative [namespace code matchNegative]
} -body {
	verbose {}
	test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
		-result {A B C}
} -cleanup {
	set ::tcltest::currentFailure $fail
	verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(negative matching):
*}

test tcltest-25.1 {
	constraint of setup/cleanup (Bug 589859)
} -setup {
	set foo 0
} -body {
	# Buggy tcltest will generate result of 2
	test tcltest-25.1.0 {} -constraints knownBug -setup {
	    incr foo
	} -body {
	    incr foo
	} -cleanup {
	    incr foo
	} -match glob -result *
	set foo
} -cleanup {
	unset foo
} -result 0

cleanupTests
}

namespace delete ::tcltest::test
return
Changes to tests/trace.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.11.8.2 2002/06/10 05:33:17 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc traceScalar {name1 name2 op} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.11.8.3 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc traceScalar {name1 name2 op} {
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
    unset x
    array set x {a 1}
    set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
    catch {unset x}
    trace add variable x array traceArray2
    set result [trace list variable x]
    set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
    catch {unset x}
    trace variable x a traceArray2
    set result [trace vinfo x]
    set result







|







348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
    unset x
    array set x {a 1}
    set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
    catch {unset x}
    trace add variable x array traceArray2
    set result [trace info variable x]
    set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
    catch {unset x}
    trace variable x a traceArray2
    set result [trace vinfo x]
    set result
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
    unset x
    concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {uplevel trace list variable x}}
    unset x
    set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
    unset x
    concat $info [trace list variable x]
} {0 {} {unset traceProc}}

test trace-10.1 {make sure array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel set x(0)}}







|









|







560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
    unset x
    concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {uplevel trace info variable x}}
    unset x
    set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
    unset x
    concat $info [trace info variable x]
} {0 {} {unset traceProc}}

test trace-10.1 {make sure array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
    unset x(0)
    concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}}
    unset x(0)
    set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
    catch {unset x(0)}
    concat $info [trace list variable x(0)]
} {0 {} {read {}}}

test trace-11.1 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x(0)}}







|









|







593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
    unset x(0)
    concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
    unset x(0)
    set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
    catch {unset x(0)}
    concat $info [trace info variable x(0)]
} {0 {} {read {}}}

test trace-11.1 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x(0)}}
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
    unset x
    set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(y) 33
    set info {}
    set cmd {traceCheck {uplevel {trace list variable x}}}
    trace add variable x unset $cmd
    unset x
    set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
    unset x
    concat $info [trace list variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; set x 44}}
    unset x







|










|







634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
    unset x
    set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(y) 33
    set info {}
    set cmd {traceCheck {uplevel {trace info variable x}}}
    trace add variable x unset $cmd
    unset x
    set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
    unset x
    concat $info [trace info variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; set x 44}}
    unset x
758
759
760
761
762
763
764
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
	    list [catch {trace $op $type foo bar} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
	test trace-14.0.[incr i] "trace command, wrong # args errors" {
	    list [catch {trace $op $type foo bar baz boo} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
    }
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace list $type foo bar} msg] $msg
    } [list 1 "$start should be \"trace list $type name\""]
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace list $type} msg] $msg
    } [list 1 "$start should be \"trace list $type name\""]
}

test trace-14.1 "trace command, wrong # args errors" {
    list [catch {trace} msg] $msg
} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
test trace-14.2 "trace command, wrong # args errors" {
    list [catch {trace add} msg] $msg
} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
test trace-14.3 "trace command, wrong # args errors" {
    list [catch {trace remove} msg] $msg
} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
    list [catch {trace list} msg] $msg
} [list 1 "wrong # args: should be \"trace list type ?arg arg ...?\""]

test trace-14.5 {trace command, invalid option} {
    list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, list, remove, variable, vdelete, or vinfo"]

# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those 
# error messages.

set i 0
set errs [list "array, read, unset, or write" "delete or rename"]
set abbvs [list {a r u w} {d r}]

foreach type {variable command} err $errs abbvlist $abbvs {
    foreach op {add remove} {
	test trace-14.6.[incr i] "trace $op $type errors" {
	    list [catch {trace $op $type x {y z w} a} msg] $msg
	} [list 1 "bad operation \"y\": must be $err"]
	foreach abbv $abbvlist {
	    test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
		list [catch {trace $op $type x $abbv a} msg] $msg
	    } [list 1 "bad operation \"$abbv\": must be $err"]
	}
	test trace-14.6.[incr i] "trace $op $type rejects null opList" {
	    list [catch {trace $op $type x {} a} msg] $msg
	} [list 1 "bad operation list \"\": must be one or more of $err"]
    }
}


test trace-14.7 {trace command, "trace variable" errors} {
    list [catch {trace variable} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.8 {trace command, "trace variable" errors} {
    list [catch {trace variable x} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]







|
|

|
|












|
|



|






|
|
>
|














>







758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
	    list [catch {trace $op $type foo bar} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
	test trace-14.0.[incr i] "trace command, wrong # args errors" {
	    list [catch {trace $op $type foo bar baz boo} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
    }
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace info $type foo bar} msg] $msg
    } [list 1 "$start should be \"trace info $type name\""]
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace info $type} msg] $msg
    } [list 1 "$start should be \"trace info $type name\""]
}

test trace-14.1 "trace command, wrong # args errors" {
    list [catch {trace} msg] $msg
} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
test trace-14.2 "trace command, wrong # args errors" {
    list [catch {trace add} msg] $msg
} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
test trace-14.3 "trace command, wrong # args errors" {
    list [catch {trace remove} msg] $msg
} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
    list [catch {trace info} msg] $msg
} [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""]

test trace-14.5 {trace command, invalid option} {
    list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]

# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those 
# error messages.

set i 0
set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"]
set abbvs [list {a r u w} {d r} {}]
proc x {} {}
foreach type {variable command execution} err $errs abbvlist $abbvs {
    foreach op {add remove} {
	test trace-14.6.[incr i] "trace $op $type errors" {
	    list [catch {trace $op $type x {y z w} a} msg] $msg
	} [list 1 "bad operation \"y\": must be $err"]
	foreach abbv $abbvlist {
	    test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
		list [catch {trace $op $type x $abbv a} msg] $msg
	    } [list 1 "bad operation \"$abbv\": must be $err"]
	}
	test trace-14.6.[incr i] "trace $op $type rejects null opList" {
	    list [catch {trace $op $type x {} a} msg] $msg
	} [list 1 "bad operation list \"\": must be one or more of $err"]
    }
}
rename x {}

test trace-14.7 {trace command, "trace variable" errors} {
    list [catch {trace variable} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.8 {trace command, "trace variable" errors} {
    list [catch {trace variable x} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
864
865
866
867
868
869
870
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
    set info
} {1}
test trace-14.15 {trace command ("list variable" option)} {
    catch {unset x}
    trace add variable x write {traceTag 1}
    trace add variable x write traceProc
    trace add variable x write {traceTag 2}
    trace list variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.16 {trace command ("list variable" option)} {
    catch {unset x}
    trace list variable x
} {}
test trace-14.17 {trace command ("list variable" option)} {
    catch {unset x}
    trace list variable x(0)
} {}
test trace-14.18 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace list variable x(0)
} {}
test trace-14.19 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace add variable x write {traceTag 1}
    proc check {} {global x; trace list variable x}
    check
} {{write {traceTag 1}}}

# Check fancy trace commands (long ones, weird arguments, etc.)

test trace-15.1 {long trace command} {
    catch {unset x}







|



|



|




|





|







866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
    set info
} {1}
test trace-14.15 {trace command ("list variable" option)} {
    catch {unset x}
    trace add variable x write {traceTag 1}
    trace add variable x write traceProc
    trace add variable x write {traceTag 2}
    trace info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.16 {trace command ("list variable" option)} {
    catch {unset x}
    trace info variable x
} {}
test trace-14.17 {trace command ("list variable" option)} {
    catch {unset x}
    trace info variable x(0)
} {}
test trace-14.18 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace info variable x(0)
} {}
test trace-14.19 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace add variable x write {traceTag 1}
    proc check {} {global x; trace info variable x}
    check
} {{write {traceTag 1}}}

# Check fancy trace commands (long ones, weird arguments, etc.)

test trace-15.1 {long trace command} {
    catch {unset x}
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
    trace add variable x unset {traceProc}
    list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
    catch {unset x}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    trace list variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
    catch {unset x}
    set info {}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    set x 44







|







1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
    trace add variable x unset {traceProc}
    list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
    catch {unset x}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    trace info variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
    catch {unset x}
    set info {}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    set x 44
1187
1188
1189
1190
1191
1192
1193
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
    rename foo bar
    rename bar foo
    set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
    proc foo {} {}
    trace add command foo rename traceCommand
    trace list command foo
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
    proc foo {} {}
    set info {}
    trace add command foo rename traceCommand
    rename foo {}
    set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo rename traceCommand
    proc foo {} {}
    rename foo bar
    set info
} {}
test trace-19.5 {trace add command deleted removes traces} {
    proc foo {} {}
    trace add command foo rename traceCommand
    proc foo {} {}
    trace list command foo
} {}

namespace eval tc {}
proc tc::tcfoo {} {}
test trace-19.6 {trace add command rename in namespace} {
    trace add command tc::tcfoo rename traceCommand
    rename tc::tcfoo tc::tcbar







|




















|







1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
    rename foo bar
    rename bar foo
    set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
    proc foo {} {}
    trace add command foo rename traceCommand
    trace info command foo
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
    proc foo {} {}
    set info {}
    trace add command foo rename traceCommand
    rename foo {}
    set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo rename traceCommand
    proc foo {} {}
    rename foo bar
    set info
} {}
test trace-19.5 {trace add command deleted removes traces} {
    proc foo {} {}
    trace add command foo rename traceCommand
    proc foo {} {}
    trace info command foo
} {}

namespace eval tc {}
proc tc::tcfoo {} {}
test trace-19.6 {trace add command rename in namespace} {
    trace add command tc::tcfoo rename traceCommand
    rename tc::tcfoo tc::tcbar
1248
1249
1250
1251
1252
1253
1254
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
# Make sure it exists again
proc foo {} {}

test trace-20.1 {trace add command (delete option)} {
    trace add command foo delete traceCommand
    rename foo ""
    set info
} {foo {} delete}
test trace-20.2 {trace add command delete doesn't trace recreated commands} {
    set info {}
    proc foo {} {}
    rename foo ""
    set info
} {}
test trace-20.2.1 {trace add command delete trace info} {
    proc foo {} {}
    trace add command foo delete traceCommand
    trace list command foo
} {{delete traceCommand}}
test trace-20.3 {trace add command implicit delete} {
    proc foo {} {}
    trace add command foo delete traceCommand
    proc foo {} {}
    set info
} {foo {} delete}
test trace-20.3.1 {trace add command delete trace info} {
    proc foo {} {}
    trace list command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
    set infotemp {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info
    rename bar {}
    lappend infotemp $info
    set info $infotemp
    unset infotemp
    set info
} {{foo bar rename} {bar {} delete}}
catch {rename foo {}}
catch {rename bar {}}

test trace-20.5 {trace add command rename and delete} {
    set infotemp {}
    set info {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info
    rename bar {}
    lappend infotemp $info
    set info $infotemp
    unset infotemp
    set info
} {{foo bar rename} {bar {} delete}}

test trace-20.6 {trace add command rename and delete in subinterp} {
    set tc [interp create]
    foreach p {traceCommand} {
	$tc eval [list proc $p [info args $p] [info body $p]]
    }
    $tc eval [list set infotemp {}]
    $tc eval [list set info {}]
    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    $tc eval [list rename foo bar]
    $tc eval {lappend infotemp $info}
    $tc eval [list rename bar {}]
    $tc eval {lappend infotemp $info}
    $tc eval {set info $infotemp}
    $tc eval [list unset infotemp]
    set info [$tc eval [list set info]]
    interp delete $tc
    set info
} {{foo bar rename} {bar {} delete}}

# I'd like it if this test could give 'foo {} d' as a result,
# but interp deletion means there is no interp to evaluate
# the trace in.
test trace-20.7 {trace add command delete in subinterp while being deleted} {
    set info {}
    set tc [interp create]
    interp alias $tc traceCommand {} traceCommand
    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    interp delete $tc
    set info
} {}

proc traceDelete {cmd old new op} {
    eval trace remove command $cmd [lindex [trace list command $cmd] 0]
    global info
    set info [list $old $new $op]
}
proc traceCmdrename {cmd old new op} {
    rename $old someothername
}
proc traceCmddelete {cmd old new op} {
    rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo {rename delete} [list traceDelete foo]
    rename foo bar
    list [set info] [trace list command bar]
} {{foo bar rename} {}}

test trace-20.9 {rename trace deletes command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}







|









|






|


|












|















|



















|















|















|







1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
# Make sure it exists again
proc foo {} {}

test trace-20.1 {trace add command (delete option)} {
    trace add command foo delete traceCommand
    rename foo ""
    set info
} {::foo {} delete}
test trace-20.2 {trace add command delete doesn't trace recreated commands} {
    set info {}
    proc foo {} {}
    rename foo ""
    set info
} {}
test trace-20.2.1 {trace add command delete trace info} {
    proc foo {} {}
    trace add command foo delete traceCommand
    trace info command foo
} {{delete traceCommand}}
test trace-20.3 {trace add command implicit delete} {
    proc foo {} {}
    trace add command foo delete traceCommand
    proc foo {} {}
    set info
} {::foo {} delete}
test trace-20.3.1 {trace add command delete trace info} {
    proc foo {} {}
    trace info command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
    set infotemp {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info
    rename bar {}
    lappend infotemp $info
    set info $infotemp
    unset infotemp
    set info
} {{foo bar rename} {::bar {} delete}}
catch {rename foo {}}
catch {rename bar {}}

test trace-20.5 {trace add command rename and delete} {
    set infotemp {}
    set info {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info
    rename bar {}
    lappend infotemp $info
    set info $infotemp
    unset infotemp
    set info
} {{foo bar rename} {::bar {} delete}}

test trace-20.6 {trace add command rename and delete in subinterp} {
    set tc [interp create]
    foreach p {traceCommand} {
	$tc eval [list proc $p [info args $p] [info body $p]]
    }
    $tc eval [list set infotemp {}]
    $tc eval [list set info {}]
    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    $tc eval [list rename foo bar]
    $tc eval {lappend infotemp $info}
    $tc eval [list rename bar {}]
    $tc eval {lappend infotemp $info}
    $tc eval {set info $infotemp}
    $tc eval [list unset infotemp]
    set info [$tc eval [list set info]]
    interp delete $tc
    set info
} {{foo bar rename} {::bar {} delete}}

# I'd like it if this test could give 'foo {} d' as a result,
# but interp deletion means there is no interp to evaluate
# the trace in.
test trace-20.7 {trace add command delete in subinterp while being deleted} {
    set info {}
    set tc [interp create]
    interp alias $tc traceCommand {} traceCommand
    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    interp delete $tc
    set info
} {}

proc traceDelete {cmd old new op} {
    eval trace remove command $cmd [lindex [trace info command $cmd] 0]
    global info
    set info [list $old $new $op]
}
proc traceCmdrename {cmd old new op} {
    rename $old someothername
}
proc traceCmddelete {cmd old new op} {
    rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo {rename delete} [list traceDelete foo]
    rename foo bar
    list [set info] [trace info command bar]
} {{foo bar rename} {}}

test trace-20.9 {rename trace deletes command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}
1411
1412
1413
1414
1415
1416
1417



1418




1419


























































































































































































































































































































































































1420









1421












1422

1423






1424
1425
1426
1427


# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
catch {rename foo {}}
catch {rename bar {}}




# Delete arrays when done, so they can be re-used as scalars




# elsewhere.




































































































































































































































































































































































































catch {unset x}












catch {unset y}









# cleanup
::tcltest::cleanupTests
return








>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>

>
>
>
>
>
>




>
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843

# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
catch {rename foo {}}
catch {rename bar {}}

proc foo {a} {
    set b $a
}

proc traceExecute {args} {
    global info
    lappend info $args
}

test trace-21.1 {trace execution: enter} {
    set info {}
    trace add execution foo enter [list traceExecute foo]
    foo 1
    trace remove execution foo enter [list traceExecute foo]
    set info
} {{foo {foo 1} enter}}

test trace-21.2 {trace exeuction: leave} {
    set info {}
    trace add execution foo leave [list traceExecute foo]
    foo 2
    trace remove execution foo leave [list traceExecute foo]
    set info
} {{foo {foo 2} 0 2 leave}}

test trace-21.3 {trace exeuction: enter, leave} {
    set info {}
    trace add execution foo {enter leave} [list traceExecute foo]
    foo 3
    trace remove execution foo {enter leave} [list traceExecute foo]
    set info
} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}}

test trace-21.4 {trace execution: enter, leave, enterstep} {
    set info {}
    trace add execution foo {enter leave enterstep} [list traceExecute foo]
    foo 3
    trace remove execution foo {enter leave enterstep} [list traceExecute foo]
    set info
} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}}

test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {
    set info {}
    trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo]
    foo 3
    trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo]
    set info
} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}}

test trace-21.6 {trace execution: enterstep, leavestep} {
    set info {}
    trace add execution foo {enterstep leavestep} [list traceExecute foo]
    foo 3
    trace remove execution foo {enterstep leavestep} [list traceExecute foo]
    set info
} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}}

test trace-21.7 {trace execution: enterstep} {
    set info {}
    trace add execution foo {enterstep} [list traceExecute foo]
    foo 3
    trace remove execution foo {enterstep} [list traceExecute foo]
    set info
} {{foo {set b 3} enterstep}}

test trace-21.8 {trace execution: leavestep} {
    set info {}
    trace add execution foo {leavestep} [list traceExecute foo]
    foo 3
    trace remove execution foo {leavestep} [list traceExecute foo]
    set info
} {{foo {set b 3} 0 3 leavestep}}

proc factorial {n} {
    if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
    return 1
}

test trace-22.1 {recursive(1) trace execution: enter} {
    set info {}
    trace add execution factorial {enter} [list traceExecute factorial]
    factorial 1
    trace remove execution factorial {enter} [list traceExecute factorial]
    set info
} {{factorial {factorial 1} enter}}

test trace-22.2 {recursive(2) trace execution: enter} {
    set info {}
    trace add execution factorial {enter} [list traceExecute factorial]
    factorial 2
    trace remove execution factorial {enter} [list traceExecute factorial]
    set info
} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}}

test trace-22.3 {recursive(3) trace execution: enter} {
    set info {}
    trace add execution factorial {enter} [list traceExecute factorial]
    factorial 3
    trace remove execution factorial {enter} [list traceExecute factorial]
    set info
} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}}

test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} {
    set info {}
    trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
    factorial 1
    trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
    join $info "\n"
} {{factorial 1} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave}

test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} {
    set info {}
    trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
    factorial 2
    trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
    join $info "\n"
} {{factorial 2} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
{expr {$n -1 }} enterstep
{expr {$n -1 }} 0 1 leavestep
{factorial 1} enterstep
{factorial 1} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave
{factorial 1} 0 1 leavestep
{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
{return 2} enterstep
{return 2} 2 2 leavestep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
{factorial 2} 0 2 leave}

test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} {
    set info {}
    trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
    factorial 3
    trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
    join $info "\n"
} {{factorial 3} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
{expr {$n -1 }} enterstep
{expr {$n -1 }} 0 2 leavestep
{factorial 2} enterstep
{factorial 2} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
{expr {$n -1 }} enterstep
{expr {$n -1 }} 0 1 leavestep
{factorial 1} enterstep
{factorial 1} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave
{factorial 1} 0 1 leavestep
{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
{return 2} enterstep
{return 2} 2 2 leavestep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
{factorial 2} 0 2 leave
{factorial 2} 0 2 leavestep
{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep
{return 6} enterstep
{return 6} 2 6 leavestep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep
{factorial 3} 0 6 leave}

proc traceDelete {cmd args} {
    eval trace remove execution $cmd [lindex [trace info execution $cmd] 0]
    global info
    set info $args
}

test trace-24.1 {delete trace during enter trace} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    foo 1
    list $info [trace info execution foo]
} {{{foo 1} enter} {}}

test trace-24.2 {delete trace during leave trace} {
    set info {}
    trace add execution foo leave [list traceDelete foo]
    foo 1
    list $info [trace info execution foo]
} {{{foo 1} 0 1 leave} {}}

test trace-24.3 {delete trace during enter-leave trace} {
    set info {}
    trace add execution foo {enter leave} [list traceDelete foo]
    foo 1
    list $info [trace info execution foo]
} {{{foo 1} enter} {}}

test trace-24.4 {delete trace during all exec traces} {
    set info {}
    trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo]
    foo 1
    list $info [trace info execution foo]
} {{{foo 1} enter} {}}

test trace-24.5 {delete trace during all exec traces except enter} {
    set info {}
    trace add execution foo {leave enterstep leavestep} [list traceDelete foo]
    foo 1
    list $info [trace info execution foo]
} {{{set b 1} enterstep} {}}

proc traceDelete {cmd args} {
    rename $cmd {}
    global info
    set info $args
}

proc foo {a} {
    set b $a
}

test trace-25.1 {delete command during enter trace} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    catch {foo 1} err
    list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.2 {delete command during leave trace} {
    set info {}
    trace add execution foo leave [list traceDelete foo]
    foo 1
    list $info [trace info execution foo]
} {{{foo 1} 0 1 leave} {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.3 {delete command during enter then leave trace} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo leave [list traceDelete foo]
    catch {foo 1} err
    list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}

proc foo {a} {
    set b $a
}
proc traceExecute2 {args} {
    global info
    lappend info $args
}

# This shows the peculiar consequences of having two traces
# at the same time: as well as tracing the procedure you want
test trace-25.4 {order dependencies of two enter traces} {
    set info {}
    trace add execution foo enter [list traceExecute traceExecute]
    trace add execution foo enter [list traceExecute2 traceExecute2]
    catch {foo 1} err
    trace remove execution foo enter [list traceExecute traceExecute]
    trace remove execution foo enter [list traceExecute2 traceExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
traceExecute2 {foo 1} enter
traceExecute {foo 1} enter
}

test trace-25.5 {order dependencies of two step traces} {
    set info {}
    trace add execution foo enterstep [list traceExecute traceExecute]
    trace add execution foo enterstep [list traceExecute2 traceExecute2]
    catch {foo 1} err
    trace remove execution foo enterstep [list traceExecute traceExecute]
    trace remove execution foo enterstep [list traceExecute2 traceExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
traceExecute2 {set b 1} enterstep
traceExecute {set b 1} enterstep
}

# We don't want the result string (5th argument), or the results
# will get unmanageable.
proc tracePostExecute {args} {
    global info
    lappend info [concat [lrange $args 0 2] [lindex $args 4]]
}
proc tracePostExecute2 {args} {
    global info
    lappend info [concat [lrange $args 0 2] [lindex $args 4]]
}

test trace-25.6 {order dependencies of two leave traces} {
    set info {}
    trace add execution foo leave [list tracePostExecute tracePostExecute]
    trace add execution foo leave [list tracePostExecute2 tracePostExecute2]
    catch {foo 1} err
    trace remove execution foo leave [list tracePostExecute tracePostExecute]
    trace remove execution foo leave [list tracePostExecute2 tracePostExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
tracePostExecute {foo 1} 0 leave
tracePostExecute2 {foo 1} 0 leave
}

test trace-25.7 {order dependencies of two leavestep traces} {
    set info {}
    trace add execution foo leavestep [list tracePostExecute tracePostExecute]
    trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]
    catch {foo 1} err
    trace remove execution foo leavestep [list tracePostExecute tracePostExecute]
    trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
tracePostExecute {set b 1} 0 leavestep
tracePostExecute2 {set b 1} 0 leavestep
}

proc foo {a} {
    set b $a
}

proc traceDelete {cmd args} {
    rename $cmd {}
    global info
    set info $args
}

test trace-25.8 {delete command during enter leave and enter/leave-step traces} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo leave [list traceDelete foo]
    trace add execution foo enterstep [list traceDelete foo]
    trace add execution foo leavestep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.9 {delete command during enter leave and leavestep traces} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo leave [list traceDelete foo]
    trace add execution foo leavestep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.10 {delete command during leave and leavestep traces} {
    set info {}
    trace add execution foo leave [list traceDelete foo]
    trace add execution foo leavestep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [trace info execution foo]
} {1 {{set b 1} 0 1 leavestep} {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.11 {delete command during enter and enterstep traces} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo enterstep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}

test trace-26.1 {trace targetCmd when invoked through an alias} {
    proc foo {args} {
	set b $args
    }
    set info {}
    trace add execution foo enter [list traceExecute foo]
    interp alias {} bar {} foo 1
    bar 2
    trace remove execution foo enter [list traceExecute foo]
    set info
} {{foo {foo 1 2} enter}}
test trace-26.2 {trace targetCmd when invoked through an alias} {
    proc foo {args} {
	set b $args
    }
    set info {}
    trace add execution foo enter [list traceExecute foo]
    interp create child
    interp alias child bar {} foo 1
    child eval bar 2
    interp delete child
    trace remove execution foo enter [list traceExecute foo]
    set info
} {{foo {foo 1 2} enter}}


# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
catch {rename foo {}}
catch {rename bar {}}

# cleanup
::tcltest::cleanupTests
return

Changes to tests/unixFCmd.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17





18
19
20
21
22
23
24
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.12 2001/07/31 19:12:07 vincentdarley Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}






# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
    if {$user == ""} {
	catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}











|





>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.12.8.1 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# These tests really need to be run from a writable directory, which
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]

# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
    catch {set user [exec whoami]}
    if {$user == ""} {
	catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
	}
    }
}

test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2/td3
    exec chmod 000 td1/td2
    set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
    exec chmod 755 td1/td2
    set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    list [catch {file rename td2 td1} msg] $msg







|

|







58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
	}
    }
}

test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2/td3
    file attributes td1/td2 -permissions 0000
    set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
    file attributes td1/td2 -permissions 0755
    set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
    cleanup
    file mkdir td1/td2
    file mkdir td2
    list [catch {file rename td2 td1} msg] $msg
114
115
116
117
118
119
120
121
122
123
124








125

126
127

128
129
130
131
132
133
134
    set line [read $pipe 1]
    catch {close $pipe}
    list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
	{unixOnly notRoot} {
    cleanup
    exec touch tf1
    exec touch tf2
    file copy -force tf1 tf2
} {}








test unixFCmd-2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {

    cleanup
    exec ln -s tf1 tf2

    file copy tf2 tf3
    file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
    cleanup
    set null "/dev/null"
    while {[file type $null] != "characterSpecial"} {







|
|


>
>
>
>
>
>
>
>
|
>

|
>







119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
    set line [read $pipe 1]
    catch {close $pipe}
    list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
	{unixOnly notRoot} {
    cleanup
    close [open tf1 a]
    close [open tf2 a]
    file copy -force tf1 tf2
} {}
test unixFCmd-2.2.1 {TclpCopyFile: src is symlink} {unixOnly notRoot dontCopyLinks} {
    # copying links should end up with real files
    cleanup
    close [open tf1 a]
    file link -symbolic tf2 tf1
    file copy tf2 tf3
    file type tf3
} {file}
test unixFCmd-2.2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
    # copying links should end up with the links copied
    cleanup
    close [open tf1 a]
    file link -symbolic tf2 tf1
    file copy tf2 tf3
    file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
    cleanup
    set null "/dev/null"
    while {[file type $null] != "characterSpecial"} {
143
144
145
146
147
148
149
150
151
152

153
154
155
156
157
158
159
160
161
    } else {
	file copy tf1 tf2
	expr {"[file type tf1]" == "[file type tf2]"}
    }
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
    cleanup
    exec touch tf1
    exec chmod 472 tf1
    file copy tf1 tf2

    string range [exec ls -l tf2] 0 9
} {-r--rwx-w-}

test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
} {}








|
|

>
|
<







158
159
160
161
162
163
164
165
166
167
168
169

170
171
172
173
174
175
176
    } else {
	file copy tf1 tf2
	expr {"[file type tf1]" == "[file type tf2]"}
    }
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
    cleanup
    close [open tf1 a]
    file attributes tf1 -permissions 0472
    file copy tf1 tf2
    file attributes tf2 -permissions
} 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-


test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}

test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
} {}

273
274
275
276
277
278
279
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
    close [open foo.test w]
    list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \
	    [file delete -force -- foo.test]
} {1 {unknown permission string format "---rwx"} {}}

close [open foo.test w]
set ::i 4
proc permcheck {permstr expected} {
    test unixFCmd-17.[incr ::i] {SetPermissionsAttribute} {unixOnly notRoot} \
	    [subst {
	file attributes foo.test -permissions $permstr
	file attributes foo.test -permissions
    }
    ] $expected
}
permcheck rwxrwxrwx	00777
permcheck r--r---w-	00442
permcheck 0		00000
permcheck u+rwx,g+r	00740
permcheck u-w		00540
permcheck o+rwx		00547
permcheck --x--x--x	00111
permcheck a+rwx		00777
file delete -force -- foo.test

test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
    # This test is nonportable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set cd [pwd]
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    exec chmod 000 $nd
    set r [list [catch {pwd} res] [string range $res 0 36]];
    cd $cd;
    exec chmod 755 $nd
    file delete $nd
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup

::tcltest::cleanupTests
return



















|
|
<


<
|

|
|
|
|
|
|
|
|









|


|






>


<
<
<
<
<
<
<
<
<
<
<
<
288
289
290
291
292
293
294
295
296

297
298

299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330












    close [open foo.test w]
    list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \
	    [file delete -force -- foo.test]
} {1 {unknown permission string format "---rwx"} {}}

close [open foo.test w]
set ::i 4
proc permcheck {testnum permstr expected} {
    test $testnum {SetPermissionsAttribute} {unixOnly notRoot} {

	file attributes foo.test -permissions $permstr
	file attributes foo.test -permissions

    } $expected
}
permcheck unixFCmd-17.4   rwxrwxrwx	00777
permcheck unixFCmd-17.5   r--r---w-	00442
permcheck unixFCmd-17.6   0		00000
permcheck unixFCmd-17.7   u+rwx,g+r	00740
permcheck unixFCmd-17.8   u-w		00540
permcheck unixFCmd-17.9   o+rwx		00547
permcheck unixFCmd-17.10  --x--x--x	00111
permcheck unixFCmd-17.11  a+rwx		00777
file delete -force -- foo.test

test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
    # This test is nonportable because SunOS generates a weird error
    # message when the current directory isn't readable.
    set cd [pwd]
    set nd $cd/tstdir
    file mkdir $nd
    cd $nd
    file attributes $nd -permissions 0000
    set r [list [catch {pwd} res] [string range $res 0 36]];
    cd $cd;
    file attributes $nd -permissions 0755
    file delete $nd
    set r
} {1 {error getting working directory name:}}

# cleanup
cleanup
cd $oldcwd
::tcltest::cleanupTests
return












Changes to tests/unixFile.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25



26
27
28
29
30
31
32
33
34
35
36
37
38
# This file contains tests for the routines in the file tclUnixFile.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFile.test,v 1.6 2000/04/10 17:19:05 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testfindexecutable\""
    puts "command, so I can't test the Tcl_FindExecutable function"
    ::tcltest::cleanupTests
    return
}




catch {
    set oldPath $env(PATH)
    close [open junk w]
    file attributes junk -perm 0777
}
set absPath [file join [pwd] junk]

test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) ""
    testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy"











|













>
>
>


<
|

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

31
32
33
34
35
36
37
38
39
40
# This file contains tests for the routines in the file tclUnixFile.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFile.test,v 1.6.18.1 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[info commands testobj] == {}} {
    puts "This application hasn't been compiled with the \"testfindexecutable\""
    puts "command, so I can't test the Tcl_FindExecutable function"
    ::tcltest::cleanupTests
    return
}

set oldpwd [pwd]
cd [temporaryDirectory]

catch {
    set oldPath $env(PATH)

    file attributes [makeFile "" junk] -perm 0777
}
set absPath [file join [temporaryDirectory] junk]

test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) ""
    testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) "/dummy"
57
58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
73
74
75
76
77
78
test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) ":/dummy"
    testfindexecutable junk
} $absPath

# cleanup
catch {set env(PATH) $oldPath}
file delete junk

::tcltest::cleanupTests
return



















|
>


<
<
<
<
<
<
<
<
<
<
<
<
59
60
61
62
63
64
65
66
67
68
69












test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} {
    set env(PATH) ":/dummy"
    testfindexecutable junk
} $absPath

# cleanup
catch {set env(PATH) $oldPath}
removeFile junk
cd $oldpwd
::tcltest::cleanupTests
return












Changes to tests/unixInit.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.25.2.1 2002/06/10 05:33:17 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

set ::tcltest::testConstraints(notInstalledInTmp) \
	[string match /tmp/lib/* [info library]]
if {[info exists env(TCL_LIBRARY)]} {
    set oldlibrary $env(TCL_LIBRARY)
    unset env(TCL_LIBRARY)
}
catch {set oldlang $env(LANG)}
set env(LANG) C

# Some tests will fail if they are run on a machine that doesn't have
# this Tcl version installed (as opposed to built) on it.
if {[catch {
    set f [open "|[list $::tcltest::tcltest]" w+]
    exec kill -PIPE [pid $f]
    close $f
} msg]} {
    set ::tcltest::testConstraints(installedTcl) 0
} else {
    set ::tcltest::testConstraints(installedTcl) 1
}

test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} {
    set x {}

    # Watch out for a race condition here.  If tcltest is too slow to start
    # then we'll kill it before it has a chance to set up its signal handler.
    
    set f [open "|[list $::tcltest::tcltest]" w+]
    puts $f "puts hi"
    flush $f
    gets $f
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list $::tcltest::tcltest]" w+]
    puts $f "puts hi"
    flush $f
    gets $f
    exec kill [pid $f]
    lappend x [catch {close $f}]

    set x
} {0 1}

# This test is really a test of code in tclUnixChan.c, but the
# channels are set up as part of initialisation of the interpreter so
# the test seems to me to fit here as well as anywhere else.
test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly installedTcl} {
    # pipe1 is a connection to a server that reports what port it
    # starts on, and delivers a constant string to the first client to
    # connect to that port before exiting.
    set pipe1 [open "|[list $::tcltest::tcltest]" r+]
    puts $pipe1 {
	proc accept {channel host port} {
	    puts $channel {puts [fconfigure stdin -peername]; exit}
	    close $channel
	    exit
	}
	puts [fconfigure [socket -server accept 0] -sockname]
	vwait forever \
	    }
    # Note the backslash above; this is important to make sure that the
    # whole string is read before an [exit] can happen...
    flush $pipe1
    set port [lindex [gets $pipe1] 2]
    set sock [socket localhost $port]
    # pipe2 is a connection to a Tcl interpreter that takes its orders
    # from the socket we hand it (i.e. the server we create above.)
    # These orders will tell it to print out the details about the
    # socket it is taking instructions from, hopefully identifying it
    # as a socket.  Which is what this test is all about.
    set pipe2 [open "|[list $::tcltest::tcltest <@$sock]" r]
    set result [gets $pipe2]

    # Clear any pending data; stops certain kinds of (non-important) errors
    fconfigure $pipe1 -blocking 0; gets $pipe1
    fconfigure $pipe2 -blocking 0; gets $pipe2

    # Close the pipes and the socket.












|

<
|
|
|
<
<
<







<
<
<
<
<
<
<
<
<
<
<
<
|





|






|












|



|



















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14

15
16
17



18
19
20
21
22
23
24












25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.25.2.2 2002/08/20 20:25:29 das Exp $


package require tcltest 2
namespace import -force ::tcltest::*




if {[info exists env(TCL_LIBRARY)]} {
    set oldlibrary $env(TCL_LIBRARY)
    unset env(TCL_LIBRARY)
}
catch {set oldlang $env(LANG)}
set env(LANG) C













test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly stdio} {
    set x {}

    # Watch out for a race condition here.  If tcltest is too slow to start
    # then we'll kill it before it has a chance to set up its signal handler.
    
    set f [open "|[list [interpreter]]" w+]
    puts $f "puts hi"
    flush $f
    gets $f
    exec kill -PIPE [pid $f]
    lappend x [catch {close $f}]

    set f [open "|[list [interpreter]]" w+]
    puts $f "puts hi"
    flush $f
    gets $f
    exec kill [pid $f]
    lappend x [catch {close $f}]

    set x
} {0 1}

# This test is really a test of code in tclUnixChan.c, but the
# channels are set up as part of initialisation of the interpreter so
# the test seems to me to fit here as well as anywhere else.
test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly stdio} {
    # pipe1 is a connection to a server that reports what port it
    # starts on, and delivers a constant string to the first client to
    # connect to that port before exiting.
    set pipe1 [open "|[list [interpreter]]" r+]
    puts $pipe1 {
	proc accept {channel host port} {
	    puts $channel {puts [fconfigure stdin -peername]; exit}
	    close $channel
	    exit
	}
	puts [fconfigure [socket -server accept 0] -sockname]
	vwait forever \
	    }
    # Note the backslash above; this is important to make sure that the
    # whole string is read before an [exit] can happen...
    flush $pipe1
    set port [lindex [gets $pipe1] 2]
    set sock [socket localhost $port]
    # pipe2 is a connection to a Tcl interpreter that takes its orders
    # from the socket we hand it (i.e. the server we create above.)
    # These orders will tell it to print out the details about the
    # socket it is taking instructions from, hopefully identifying it
    # as a socket.  Which is what this test is all about.
    set pipe2 [open "|[list [interpreter] <@$sock]" r]
    set result [gets $pipe2]

    # Clear any pending data; stops certain kinds of (non-important) errors
    fconfigure $pipe1 -blocking 0; gets $pipe1
    fconfigure $pipe2 -blocking 0; gets $pipe2

    # Close the pipes and the socket.
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

186
187

188
189
190
191
192
193





194

195
196
197
198
199
200
201









202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
    } then {
	subst "OK"
    } else {
	subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
    }
} {OK}

proc getlibpath "{program [list $::tcltest::tcltest]}" {
    set f [open "|[list $program]" w+]
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

# Some tests require the testgetdefenc command

set ::tcltest::testConstraints(testgetdefenc) \
	[expr {[info commands testgetdefenc] != {}}]

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
	{unixOnly testgetdefenc} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
	{unixOnly installedTcl} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    set developLib tcl[info patchlevel]/library
    set prefix [file dirname [file dirname $::tcltest::tcltest]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly installedTcl} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
	{unixOnly installedTcl} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
	{unixOnly installedTcl} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
	{unixOnly installedTcl} {

    file delete -force /tmp/sparkly
    file mkdir /tmp/sparkly/bin

    file copy $::tcltest::tcltest /tmp/sparkly/bin/tcltest

    file mkdir /tmp/sparkly/lib/tcl[info tclversion]
    close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 1]





    file delete -force /tmp/sparkly

    set x
} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}









test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unixOnly notInstalledInTmp} {
    # Checking for Bug 219416
    # When a program that embeds the Tcl library, like tcltest, is
    # installed near the "root" of the file system, there was a problem
    # constructing directories relative to the executable.  When a 
    # relative ".." went past the root, relative path names were created
    # rather than absolute pathnames.  In some cases, accessing past the
    # root caused memory access violations too.
    #
    # The bug is now fixed, but here we check for it by making sure that
    # the directories constructed relative to the executable are all
    # absolute pathnames, even when the executable is installed near
    # the root of the filesystem.
    #
    # The only directory near the root we are likely to have write access
    # to is /tmp.
    file delete -force /tmp/sparkly
    file delete -force /tmp/lib/tcl[info tclversion]
    file mkdir /tmp/sparkly
    file copy $::tcltest::tcltest /tmp/sparkly/tcltest

    # Keep any existing /tmp/lib directory
    set deletelib 1
    if {[file exists /tmp/lib]} {
	if {[file isdirectory /tmp/lib]} {
	    set deletelib 0
	} else {







|










<
|










|




|






|









|









|














|
>
|
|
>
|
|
|
|

|
>
>
>
>
>
|
>

|





>
>
>
>
>
>
>
>
>
|


















|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109

110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
    } then {
	subst "OK"
    } else {
	subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
    }
} {OK}

proc getlibpath [list [list program [interpreter]]] {
    set f [open "|[list $program]" w+]
    fconfigure $f -buffering none
    puts $f {puts $tcl_libPath; exit}
    set path [gets $f]
    close $f
    return $path
}

# Some tests require the testgetdefenc command


testConstraint testgetdefenc [llength [info commands testgetdefenc]]

test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
	{unixOnly testgetdefenc} {
    set origDir [testgetdefenc]
    testsetdefenc slappy
    set path [testgetdefenc]
    testsetdefenc $origDir
    set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
	{unixOnly stdio} {
    set path [getlibpath]

    set installLib lib/tcl[info tclversion]
    set developLib tcl[info patchlevel]/library
    set prefix [file dirname [file dirname [interpreter]]]

    set x {}
    lappend x [string compare [lindex $path 0] $prefix/$installLib]
    lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
    set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly stdio} {
    # ((str != NULL) && (str[0] != '\0')) 

    set env(TCL_LIBRARY) sparkly
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
	{unixOnly stdio} {
    # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))

    set env(TCL_LIBRARY) /a/b/tcl1.7
    set path [getlibpath]
    unset env(TCL_LIBRARY)

    lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
	{unixOnly stdio} {
    # Child process translates env variable from native encoding.

    set env(TCL_LIBRARY) "\xa7"
    set x [lindex [getlibpath] 0]
    unset env(TCL_LIBRARY)
    unset env(LANG)

    set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
	{unixOnly stdio} {
    makeDirectory tmp
    makeDirectory [file join tmp sparkly]
    makeDirectory [file join tmp sparkly bin]
    file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \
	    bin tcltest]
    makeDirectory [file join tmp sparkly lib]
    makeDirectory [file join tmp sparkly lib tcl[info tclversion]]
    makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl]

    set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \
	    bin tcltest]] 0 1]
    removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl]
    removeDirectory [file join tmp sparkly lib tcl[info tclversion]]
    removeDirectory [file join tmp sparkly lib]
    removeDirectory [file join tmp sparkly bin]
    removeDirectory [file join tmp sparkly]
    removeDirectory tmp
    set x
} [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
	{emptyTest unixOnly} {
    # would need test command to get defaultLibDir and compare it to
    # [lindex $auto_path end]
} {}
#
# The following two tests write to the directory /tmp/sparkly instead
# of to [temporaryDirectory].  This is because the failures tested by
# these tests need paths near the "root" of the file system to present
# themselves.
#
testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}]
testConstraint noTmpInstall [expr {![file exists \
				[file join /tmp lib tcl[info tclversion]]]}]
test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall} {
    # Checking for Bug 219416
    # When a program that embeds the Tcl library, like tcltest, is
    # installed near the "root" of the file system, there was a problem
    # constructing directories relative to the executable.  When a 
    # relative ".." went past the root, relative path names were created
    # rather than absolute pathnames.  In some cases, accessing past the
    # root caused memory access violations too.
    #
    # The bug is now fixed, but here we check for it by making sure that
    # the directories constructed relative to the executable are all
    # absolute pathnames, even when the executable is installed near
    # the root of the filesystem.
    #
    # The only directory near the root we are likely to have write access
    # to is /tmp.
    file delete -force /tmp/sparkly
    file delete -force /tmp/lib/tcl[info tclversion]
    file mkdir /tmp/sparkly
    file copy [interpreter] /tmp/sparkly/tcltest

    # Keep any existing /tmp/lib directory
    set deletelib 1
    if {[file exists /tmp/lib]} {
	if {[file isdirectory /tmp/lib]} {
	    set deletelib 0
	} else {
244
245
246
247
248
249
250

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

    # Clean up temporary installation
    file delete -force /tmp/sparkly
    file delete -force /tmp/lib/tcl[info tclversion]
    if {$deletelib} {file delete -force /tmp/lib}
    set allAbsolute
} 1

test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {
	unixOnly} {
    # Checking for Bug 438014
    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    file mkdir /tmp/sparkly
    file copy $::tcltest::tcltest /tmp/sparkly/tcltest

    file mkdir /tmp/library/
    close [open /tmp/library/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]

    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    set x
} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
        /tmp/library /library /tcl[info patchlevel]/library]
test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly installedTcl} {


    set env(LANG) C

    set f [open "|[list $::tcltest::tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} {iso8859-1}
test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly installedTcl} {
    set env(LANG) japanese
    catch {set oldlc_all $env(LC_ALL)}
    set env(LC_ALL) japanese

    set f [open "|[list $::tcltest::tcltest]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)
    unset env(LC_ALL)
    catch {set env(LC_ALL) $oldlc_all}







>
|
<




|











|
>
>


|







|
|




|







244
245
246
247
248
249
250
251
252

253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295

    # Clean up temporary installation
    file delete -force /tmp/sparkly
    file delete -force /tmp/lib/tcl[info tclversion]
    if {$deletelib} {file delete -force /tmp/lib}
    set allAbsolute
} 1
testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}]
test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild} {

    # Checking for Bug 438014
    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    file mkdir /tmp/sparkly
    file copy [interpreter] /tmp/sparkly/tcltest

    file mkdir /tmp/library/
    close [open /tmp/library/init.tcl w]

    set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]

    file delete -force /tmp/sparkly
    file delete -force /tmp/library
    set x
} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
        /tmp/library /library /tcl[info patchlevel]/library]
test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
	unixOnly stdio
} -body {
    set env(LANG) C

    set f [open "|[list [interpreter]]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)

    set enc
} -match regexp -result ^iso8859-15?$
test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly stdio} {
    set env(LANG) japanese
    catch {set oldlc_all $env(LC_ALL)}
    set env(LC_ALL) japanese

    set f [open "|[list [interpreter]]" w+]
    fconfigure $f -buffering none
    puts $f {puts [encoding system]; exit}
    set enc [gets $f]
    close $f
    unset env(LANG)
    unset env(LC_ALL)
    catch {set env(LC_ALL) $oldlc_all}
Changes to tests/unixNotfy.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.9 2000/04/10 17:19:05 ericm 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












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.9.18.1 2002/08/20 20:25:29 das Exp $

# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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

# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
    catch {vwait x}
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
    catch {vwait x}
    set f1 [open foo w]
    set f2 [open foo2 w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
    vwait y
    close $f2
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}


test unixNotfy-2.1 {Tcl_DeleteFileHandler} {unixOnly testthread} {
    update
    set f [open foo w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    testthread create "after 500
    testthread send [testthread id] {set x ok}
    testthread exit"
    vwait x
    set x
} {ok}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly testthread} {
    update
    set f1 [open foo w]
    set f2 [open foo2 w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
    vwait y
    close $f2
    testthread create "after 500
    testthread send [testthread id] {set x ok}
    testthread exit"
    vwait x
    set x
} {ok}



# cleanup
file delete foo
file delete foo2
::tcltest::cleanupTests
return



















|







|
|












|









|

|
|














<

<
<


<
<
<
<
<
<
<
<
<
<
<
<
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

89


90
91













# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.

test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
    catch {vwait x}
    set f [open [makeFile "" foo] w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
    catch {vwait x}
    set f1 [open [makeFile "" foo] w]
    set f2 [open [makeFile "" foo2] w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
    vwait y
    close $f2
    list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x":  would wait forever}}


test unixNotfy-2.1 {Tcl_DeleteFileHandler} {unixOnly testthread} {
    update
    set f [open [makeFile "" foo] w]
    fileevent $f writable {set x 1}
    vwait x
    close $f
    testthread create "after 500
    testthread send [testthread id] {set x ok}
    testthread exit"
    vwait x
    set x
} {ok}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} {unixOnly testthread} {
    update
    set f1 [open [makeFile "" foo] w]
    set f2 [open [makeFile "" foo2] w]
    fileevent $f1 writable {set x 1}
    fileevent $f2 writable {set y 1}
    vwait x
    close $f1
    vwait y
    close $f2
    testthread create "after 500
    testthread send [testthread id] {set x ok}
    testthread exit"
    vwait x
    set x
} {ok}



# cleanup


::tcltest::cleanupTests
return












Changes to tests/uplevel.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  uplevel
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: uplevel.test,v 1.6 2000/04/10 17:19:05 ericm Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc a {x y} {













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Commands covered:  uplevel
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: uplevel.test,v 1.6.18.1 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc a {x y} {
107
108
109
110
111
112
113















114
115
116
117
118
119
120
    global x y
    set x [info level]
    set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3
















# cleanup
::tcltest::cleanupTests
return










>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
    global x y
    set x [info level]
    set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3

namespace eval ns1 {
    proc set args {return ::ns1}
}
proc a2 {} {
    uplevel {set x ::}
}
test uplevel-6.1 {uplevel and shadowed cmds} {
    set res [namespace eval ns1 a2]
    lappend res [namespace eval ns2 a2]
    lappend res [namespace eval ns1 a2]
    namespace eval ns1 {rename set {}}
    lappend res [namespace eval ns1 a2]
} {::ns1 :: ::ns1 ::}


# cleanup
::tcltest::cleanupTests
return



Changes to tests/var.test.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: var.test,v 1.17.8.1 2002/02/05 02:22:04 wolfsuit Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}








|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: var.test,v 1.17.8.2 2002/08/20 20:25:29 das Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
    upvar #0 aaaaa xxxxx
    set xxxxx
} {hello}
test var-3.9 {MakeUpvar, my var has invalid ns name} {
    catch {unset aaaaa}
    set aaaaa 789789
    list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
} {1 {bad variable name "test_ns_fred::lnk": unknown namespace}}

if {[info commands testgetvarfullname] != {}} {
    test var-4.1 {Tcl_GetVariableName, global variable} {
        catch {unset a}
        set a 123
        testgetvarfullname a global
    } ::a







|







257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
    upvar #0 aaaaa xxxxx
    set xxxxx
} {hello}
test var-3.9 {MakeUpvar, my var has invalid ns name} {
    catch {unset aaaaa}
    set aaaaa 789789
    list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}

if {[info commands testgetvarfullname] != {}} {
    test var-4.1 {Tcl_GetVariableName, global variable} {
        catch {unset a}
        set a 123
        testgetvarfullname a global
    } ::a
Changes to tests/winDde.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winDde.test,v 1.11 2001/08/22 23:56:14 hobbs Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {$tcl_platform(platform) == "windows"} {











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winDde.test,v 1.11.8.1 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {$tcl_platform(platform) == "windows"} {
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
	puts ready
	vwait done
	update
	exit
    }
    close $f
    
    set f [open |[list $tcltest::tcltest $::scriptName] r]
    gets $f
    return $f
}

test winDde-1.1 {Settings the server's topic name} {pcOnly} {
    list [dde servername foobar] [dde servername] [dde servername self]
}  {foobar foobar self}







|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
	puts ready
	vwait done
	update
	exit
    }
    close $f
    
    set f [open |[list [interpreter] $::scriptName] r]
    gets $f
    return $f
}

test winDde-1.1 {Settings the server's topic name} {pcOnly} {
    list [dde servername foobar] [dde servername] [dde servername self]
}  {foobar foobar self}
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150

test winDde-3.5 {DDE request locally} {pcOnly} {
    set a ""
    dde execute TclEval self {set a "foo"}
    dde request -binary TclEval self a
} "foo\x00"

test winDde-4.1 {DDE execute remotely} {pcOnly} {
    set a ""
    set child [createChildProcess child]
    dde execute TclEval child {set a "foo"}
    dde execute TclEval child {set done 1}

    set a
} ""

test winDde-4.2 {DDE execute remotely} {pcOnly} {
    set a ""
    set child [createChildProcess child]
    dde execute -async TclEval child {set a "foo"}
    dde execute TclEval child {set done 1}

    set a
} ""

test winDde-4.3 {DDE request locally} {pcOnly} {
    set a ""
    set child [createChildProcess child]
    dde execute TclEval child {set a "foo"}
    set a [dde request TclEval child a]
    dde execute TclEval child {set done 1}

    set a
} foo

test winDde-4.4 {DDE eval locally} {pcOnly} {
    set a ""
    set child [createChildProcess child]
    set a [dde eval child set a "foo"]
    dde execute TclEval child {set done 1}

    set a
} foo







|








|








|









|







108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150

test winDde-3.5 {DDE request locally} {pcOnly} {
    set a ""
    dde execute TclEval self {set a "foo"}
    dde request -binary TclEval self a
} "foo\x00"

test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {
    set a ""
    set child [createChildProcess child]
    dde execute TclEval child {set a "foo"}
    dde execute TclEval child {set done 1}

    set a
} ""

test winDde-4.2 {DDE execute remotely} {stdio pcOnly} {
    set a ""
    set child [createChildProcess child]
    dde execute -async TclEval child {set a "foo"}
    dde execute TclEval child {set done 1}

    set a
} ""

test winDde-4.3 {DDE request locally} {stdio pcOnly} {
    set a ""
    set child [createChildProcess child]
    dde execute TclEval child {set a "foo"}
    set a [dde request TclEval child a]
    dde execute TclEval child {set done 1}

    set a
} foo

test winDde-4.4 {DDE eval locally} {stdio pcOnly} {
    set a ""
    set child [createChildProcess child]
    set a [dde eval child set a "foo"]
    dde execute TclEval child {set done 1}

    set a
} foo
Changes to tests/winFCmd.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFCmd.test,v 1.14.4.2 2002/06/10 05:33:17 wolfsuit Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFCmd.test,v 1.14.4.3 2002/08/20 20:25:29 das Exp $
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
	}
    }
}

if {[string equal $tcl_platform(platform) "windows"]} {
    if {[string equal $tcl_platform(os) "Windows NT"] \
      && [string equal [string index $tcl_platform(osVersion) 0] "5"]} {
	tcltest::testConstraint win2000 1
	tcltest::testConstraint notWin2000 0
    } else {
	tcltest::testConstraint win2000 0
	tcltest::testConstraint notWin2000 1
    }
} else {
    tcltest::testConstraint win2000 0
    tcltest::testConstraint notWin2000 0
}

set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0

# find a CD-ROM so we can test read-only filesystems.








|
|

|
|


|
|







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
	}
    }
}

if {[string equal $tcl_platform(platform) "windows"]} {
    if {[string equal $tcl_platform(os) "Windows NT"] \
      && [string equal [string index $tcl_platform(osVersion) 0] "5"]} {
	tcltest::testConstraint win2000orXP 1
	tcltest::testConstraint winOlderThan2000 0
    } else {
	tcltest::testConstraint win2000orXP 0
	tcltest::testConstraint winOlderThan2000 1
    }
} else {
    tcltest::testConstraint win2000orXP 0
    tcltest::testConstraint winOlderThan2000 0
}

set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0

# find a CD-ROM so we can test read-only filesystems.

198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {win2000} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} {notWin2000} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile mv tf1 tf2
    list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {win2000} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} {notWin2000} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {nt} {
    # under 95, this would actually succeed and move the current dir out from 
    # under the current process!
    cleanup
    file delete /tf1
    list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} {







|



|



|




|


















|



|



|







198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly win2000orXP} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} {pcOnly winOlderThan2000} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {pcOnly 95} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {pcOnly nt} {
    cleanup
    createfile tf1
    list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile mv tf1 tf2
    list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} {
    cleanup
    list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT} 
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly win2000orXP} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} {pcOnly winOlderThan2000} {
    cleanup
    list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {pcOnly nt} {
    # under 95, this would actually succeed and move the current dir out from 
    # under the current process!
    cleanup
    file delete /tf1
    list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} {
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
    list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} {
    cleanup
    createfile tf1
    list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {win2000} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} {nt notWin2000} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile cp tf1 tf2







|







|



|



|







371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
    list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} {
    cleanup
    createfile tf1
    list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {pcOnly 95} {
    cleanup
    createfile tf1
    set fd [open tf2 w]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
    set msg
} {1 EACCES}
test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {pcOnly win2000orXP} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} {pcOnly nt winOlderThan2000} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {pcOnly 95} {
    cleanup
    list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
    cleanup
    createfile tf1 tf1
    testfile cp tf1 tf2
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} {1 tf1}
test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} {
    cleanup
    createfile tf1
    createfile tf2
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd







|







441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
    cleanup
    createfile tf1 tf1
    createfile tf2 tf2
    testchmod 000 tf2
    testfile cp tf1 tf2
    list [file writable tf2] [contents tf2]
} {1 tf1}
test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {pcOnly 95} {
    cleanup
    createfile tf1
    createfile tf2
    testchmod 000 tf2
    set fd [open tf2]
    set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
    close $fd
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
    set fd [open tf1 w]
    testchmod 000 tf1
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}

test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {nt cdrom} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {95 cdrom} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile mkdir td1} msg] $msg
} {1 EEXIST}







|


|







513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
    set fd [open tf1 w]
    testchmod 000 tf1
    set msg [list [catch {testfile rm tf1} msg] $msg]
    close $fd
    set msg
} {1 EACCES}

test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {pcOnly nt cdrom} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {pcOnly 95 cdrom} {
    list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} {
    cleanup
    file mkdir td1
    list [catch {testfile mkdir td1} msg] $msg
} {1 EEXIST}
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} {
    cleanup
    list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} {
    cleanup
    list [catch {testfile rmdir /} msg] $msg
} {1 {/ EACCES}}
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {pcOnly} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly} {
    cleanup
    file mkdir td1/td2







|



|



|











|







588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {pcOnly 95} {
    cleanup
    list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {pcOnly nt} {
    cleanup
    list [catch {testfile rmdir /} msg] $msg
} {1 {/ EACCES}}
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {pcOnly 95} {
    cleanup
    createfile tf1
    list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {pcOnly} {
    cleanup
    file mkdir td1
    testchmod 000 td1
    testfile rmdir td1
    file exists td1
} {0}
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {pcOnly 95} {
    cleanup
    file mkdir td1/td2
    list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly} {
    cleanup
    file mkdir td1/td2
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} {
    # cdrom can return either d:\ or D:/, but we only care about the errcode
    list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
} {1 EEXIST}
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} {
    list [catch {testfile rmdir $cdrom/} msg]  [lindex $msg 1]
} {1 EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
	{pcOnly} {
    # can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} {







|



|







674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {pcOnly 95 cdrom} {
    # cdrom can return either d:\ or D:/, but we only care about the errcode
    list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
} {1 EEXIST}
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {pcOnly nt cdrom} {
    list [catch {testfile rmdir $cdrom/} msg]  [lindex $msg 1]
} {1 EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
	{pcOnly} {
    # can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} {
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EEXIST}}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EACCES}}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly} {
    cleanup
    file mkdir td1







|




|







707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly} {
    cleanup
    file mkdir td1
    createfile td1/tf1 tf1
    testfile cpdir td1 td2
    contents td2/tf1
} {tf1}    
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {pcOnly 95} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EEXIST}}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {pcOnly nt} {
    cleanup
    file mkdir td1
    list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EACCES}}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly} {
    cleanup
    file mkdir td1
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800

test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly} {
    cleanup
    file mkdir td1
    createfile td1/tf1
    testfile rmdir -force td1
} {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} {
    cleanup
    file mkdir td1
    set fd [open td1/tf1 w]
    set msg [list [catch {testfile rmdir -force td1} msg] $msg]
    close $fd
    set msg
} {1 {td1\tf1 EACCES}}







|







786
787
788
789
790
791
792
793
794
795
796
797
798
799
800

test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly} {
    cleanup
    file mkdir td1
    createfile td1/tf1
    testfile rmdir -force td1
} {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} {pcOnly 95} {
    cleanup
    file mkdir td1
    set fd [open td1/tf1 w]
    set msg [list [catch {testfile rmdir -force td1} msg] $msg]
    close $fd
    set msg
} {1 {td1\tf1 EACCES}}
Changes to tests/winFile.test.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
# This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFile.test,v 1.6.18.1 2002/06/10 05:33:17 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test winFile-1.1 {TclpGetUserHome} {pcOnly} {
    list [catch {glob ~nosuchuser} msg] $msg
} {1 {user "nosuchuser" doesn't exist}}
test winFile-1.2 {TclpGetUserHome} {nt nonPortable} {
    # The administrator account should always exist.

    catch {glob ~administrator}
} {0}
test winFile-1.2 {TclpGetUserHome} {95} {
    # Find some user in system.ini and then see if they have a home.

    set f [open $::env(windir)/system.ini]
    set x 0
    while {![eof $f]} {
	set line [gets $f]
	if {$line == "\[Password Lists]"} {
	    gets $f
	    set name [lindex [split [gets $f] =] 0]
	    if {$name != ""} {
		set x [catch {glob ~$name}]
		break
	    }
	}
    }
    close $f
    set x
} {0}
test winFile-1.3 {TclpGetUserHome} {nt nonPortable} {
    catch {glob ~stanton@workgroup}
} {0}

test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly} {
    makeFile {} GlobCapS
    set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]]
    removeFile GlobCapS
    set result
} {GlobCapS GlobCapS}

test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} {
    makeFile {} globlower
    set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]]
    removeFile globlower
    set result
} {globlower globlower}

test winFile-3.1 {file system} {pcOnly} {
    set res "volume types ok"
    foreach vol [file volumes] {



	if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} {
	    set res "For $vol, we found [file system $vol]\
	      and [testvolumetype $vol] are different"
	    break

	}
    }
    set res
} {volume types ok}

# cleanup
::tcltest::cleanupTests












|









|




|


















|




















>
>
>
|
|
|
|
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
# This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFile.test,v 1.6.18.2 2002/08/20 20:25:29 das Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

test winFile-1.1 {TclpGetUserHome} {pcOnly} {
    list [catch {glob ~nosuchuser} msg] $msg
} {1 {user "nosuchuser" doesn't exist}}
test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} {
    # The administrator account should always exist.

    catch {glob ~administrator}
} {0}
test winFile-1.2 {TclpGetUserHome} {pcOnly 95} {
    # Find some user in system.ini and then see if they have a home.

    set f [open $::env(windir)/system.ini]
    set x 0
    while {![eof $f]} {
	set line [gets $f]
	if {$line == "\[Password Lists]"} {
	    gets $f
	    set name [lindex [split [gets $f] =] 0]
	    if {$name != ""} {
		set x [catch {glob ~$name}]
		break
	    }
	}
    }
    close $f
    set x
} {0}
test winFile-1.3 {TclpGetUserHome} {pcOnly nt nonPortable} {
    catch {glob ~stanton@workgroup}
} {0}

test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly} {
    makeFile {} GlobCapS
    set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]]
    removeFile GlobCapS
    set result
} {GlobCapS GlobCapS}

test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} {
    makeFile {} globlower
    set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]]
    removeFile globlower
    set result
} {globlower globlower}

test winFile-3.1 {file system} {pcOnly} {
    set res "volume types ok"
    foreach vol [file volumes] {
	# Have to catch in case there is a removable drive (CDROM, floppy)
	# with nothing in it.
	catch {
	    if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} {
		set res "For $vol, we found [file system $vol]\
		  and [testvolumetype $vol] are different"
		break
	    }
	}
    }
    set res
} {volume types ok}

# cleanup
::tcltest::cleanupTests
Changes to tests/winPipe.test.
8
9
10
11
12
13
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

41
42
43
44

45
46
47
48
49
50
51
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
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winPipe.test,v 1.15.4.1 2002/06/10 05:33:17 wolfsuit Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}


set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]

set ::tcltest::testConstraints(cat32) [file exists $cat32]

if {[catch {puts console1 ""}]} {
    set ::tcltest::testConstraints(AllocConsole) 1
} else {
    set ::tcltest::testConstraints(.console) 1
}

set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big	
append big $big
append big $big
append big $big
append big $big


set f [open "little" w] 
puts -nonewline $f "little"
close $f


set f [open "big" w]
puts -nonewline $f $big
close $f

proc contents {file} {
    set f [open $file r]
    set r [read $f]
    close $f
    set r
}

set f [open more w]
puts $f {
    while {[eof stdin] == 0} {
	puts -nonewline [read stdin]
    }

}
close $f


test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly stdio cat32} {
    exec $cat32 < little > stdout 2> stderr
    list [contents stdout] [contents stderr]
} {little stderr32}
test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly stdio cat32} {
    exec $cat32 < big > stdout 2> stderr
    list [contents stdout] [contents stderr]
} "{$big} stderr32"
test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt stdio cat32} {
    exec $::tcltest::tcltest more < little | $cat32 > stdout 2> stderr
    list [contents stdout] [contents stderr]
} {little stderr32}
test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {nt stdio cat32} {
    exec $::tcltest::tcltest more < big | $cat32 > stdout 2> stderr
    list [contents stdout] [contents stderr]
} "{$big} stderr32"
test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {95 stdio cat32} {
    exec command /c type big |& $cat32 > stdout 2> stderr
    list [contents stdout] [contents stderr]
} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
	{pcOnly stdio cat32 AllocConsole} {
    # would block waiting for human input
} {}
test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly stdio cat32} {
    exec $cat32 < nul > stdout 2> stderr
    list [contents stdout] [contents stderr]
} {{} stderr32}
test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly stdio cat32} {
    # doesn't work
} {}
test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \
	{pcOnly stdio cat32 .console} {
    exec $cat32 > stdout 2> stderr
    list [contents stdout] [contents stderr]
} {{} stderr32}
test winpipe-1.10 {32 bit comprehensive tests: from file handle} \
	{pcOnly stdio cat32} {
    set f [open "little" r]
    exec $cat32 <@$f > stdout 2> stderr
    close $f
    list [contents stdout] [contents stderr]
} {little stderr32}
test winpipe-1.11 {32 bit comprehensive tests: read from application} \
	{pcOnly stdio cat32} {
    set f [open "|[list $cat32] < little" r]
    gets $f line
    catch {close $f} msg
    list $line $msg
} {little stderr32}
test winpipe-1.12 {32 bit comprehensive tests: a little to file} \
	{pcOnly stdio cat32} {
    exec $cat32 < little > stdout 2> stderr
    list [contents stdout] [contents stderr]
} {little stderr32}
test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \
	{pcOnly stdio cat32} {
    exec $cat32 < big > stdout 2> stderr
    list [contents stdout] [contents stderr]
} "{$big} stderr32"
test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \
	{pcOnly stdio cat32} {
    exec $cat32 < little | $::tcltest::tcltest more > stdout 2> stderr
    list [contents stdout] [contents stderr]
} {little stderr32}
test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \
	{pcOnly stdio cat32} {
    exec $cat32 < big | $::tcltest::tcltest more > stdout 2> stderr
    list [contents stdout] [contents stderr]
} "{$big} stderr32"
test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly stdio cat32} {
    catch {exec $cat32 << "You should see this\n" >@stdout} msg
    set msg
} stderr32
test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly stdio cat32} {
    # some apps hang when sending a large amount to NUL.  $cat32 isn't one.
    catch {exec $cat32 < big > nul} msg
    set msg
} stderr32
test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \
	{pcOnly stdio cat32 .console} {
    exec $cat32 < big >&@stdout 
} {}
test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly stdio cat32} {
    set f1 [open "stdout" w]
    set f2 [open "stderr" w]
    exec $cat32 < little >@$f1 2>@$f2
    close $f1
    close $f2
    list [contents stdout] [contents stderr]
} {little stderr32}
test winpipe-1.20 {32 bit comprehensive tests: write to application} \
	{pcOnly stdio cat32} {
    set f [open |[list $cat32 >stdout] w]
    puts -nonewline $f "foo"
    catch {close $f} msg
    list [contents stdout] $msg
} {foo stderr32}
test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
	{pcOnly stdio cat32} {
    set f [open "|[list $cat32]" r+]
    puts $f $big
    puts $f \032
    flush $f
    set r [read $f 64]
    catch {close $f}
    set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
test winpipe-1.22 {Checking command.com for Win95/98 hanging} {95 stdio} {
    exec command.com /c dir /b
    set result 1
} 1
file delete more

test winpipe-4.1 {Tcl_WaitPid} {nt stdio cat32} {
    proc readResults {f} {
	global x result
	if { [eof $f] } {
	    close $f
	    set x 1
	} else {
	    set line [read $f ]
	    set result "$result$line"
	}
    }

    set f [open "|[list $cat32] < big 2> stderr" r]
    fconfigure $f  -buffering none -blocking 0
    fileevent $f readable "readResults $f"
    set x 0
    set result ""
    vwait x
    list $result $x [contents stderr]
} "{$big} 1 stderr32"


close [open nothing w]

catch {set env_tmp $env(TMP)}
catch {set env_temp $env(TEMP)}

set env(TMP) c:/
set env(TEMP) c:/

test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} {
    set x {}
    set existing [glob -nocomplain c:/tcl*.tmp]
    exec $::tcltest::tcltest < nothing 
    foreach p [glob -nocomplain c:/tcl*.tmp] {
	if {[lsearch $existing $p] == -1} {
	    lappend x $p
	}
    }
    set x
} {}
test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} {
    set tmp $env(TMP)
    set temp $env(TEMP)
    unset env(TMP)
    unset env(TEMP)
    exec $::tcltest::tcltest < nothing
    set env(TMP) $tmp
    set env(TEMP) $temp
    set x {}
} {}
test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \
	{pcOnly stdio} {
    set tmp $env(TMP)
    set env(TMP) snarky
    exec $::tcltest::tcltest < nothing
    set env(TMP) $tmp
    set x {}
} {}
test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \
	{pcOnly stdio} {
    set tmp $env(TMP)
    set temp $env(TEMP)
    unset env(TMP)
    set env(TEMP) snarky
    exec $::tcltest::tcltest < nothing
    set env(TMP) $tmp
    set env(TEMP) $temp
    set x {}
} {}

test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \
	{pcOnly stdio cat32} {
    set f [open "|[list $cat32]" r+]
    fconfigure $f -blocking 0
    fileevent $f writable { set x writable }
    set x {}
    vwait x
    fileevent $f writable {}
    fileevent $f readable { lappend x readable }
    after 100 { lappend x timeout }
    vwait x
    puts $f foobar
    flush $f
    vwait x
    lappend x [read $f]
    after 100 { lappend x timeout }
    vwait x
    lappend x [catch {close $f} msg] $msg
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
	{pcOnly stdio cat32} {
    set f [open "|[list $cat32]" r+]
    fconfigure $f -blocking 0
    fileevent $f writable { set x writable }
    set x {}
    vwait x
    puts -nonewline $f $big$big$big$big
    flush $f
    after 100 { lappend x timeout }
    vwait x
    lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}

makeFile {
    puts "[list $argv0 $argv]"
} echoArgs.tcl

test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly stdio} {
    exec $::tcltest::tcltest echoArgs.tcl foo "" bar
} {echoArgs.tcl {foo {} bar}}
test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly stdio} {
    exec $::tcltest::tcltest echoArgs.tcl foo \" bar
} {echoArgs.tcl {foo {"} bar}}

# restore old values for env(TMP) and env(TEMP)

if {[catch {set env(TMP) $env_tmp}]} {
    unset env(TMP)
}
if {[catch {set env(TEMP) $env_temp}]} {







|

<
|
|
|
>




















>
|



>
|










|
<



>
|
|
>

|
|
|

|
|
|

|
|
|

|
|
|

|
|
|


|


|
|
|

|



|
|
|


|
|
|

|


|
|





|
|
|


|
|
|


|
|
|


|
|
|

|



|

|



|
|

|
|
|
|


|


|
|


|


|








|





|











|





|


>
|







|


|







|




|





|


|




|




|






|



















|












|

|

|
|
|
|
|
|







8
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winPipe.test,v 1.15.4.2 2002/08/20 20:25:29 das Exp $


package require tcltest
namespace import -force ::tcltest::*

testConstraint exec [llength [info commands exec]]

set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]

set ::tcltest::testConstraints(cat32) [file exists $cat32]

if {[catch {puts console1 ""}]} {
    set ::tcltest::testConstraints(AllocConsole) 1
} else {
    set ::tcltest::testConstraints(.console) 1
}

set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big	
append big $big
append big $big
append big $big
append big $big

set path(little) [makeFile {} little]
set f [open $path(little) w] 
puts -nonewline $f "little"
close $f

set path(big) [makeFile {} big]
set f [open $path(big) w]
puts -nonewline $f $big
close $f

proc contents {file} {
    set f [open $file r]
    set r [read $f]
    close $f
    set r
}

set path(more) [makeFile {

    while {[eof stdin] == 0} {
	puts -nonewline [read stdin]
    }
} more]

set path(stdout) [makeFile {} stdout]
set path(stderr) [makeFile {} stderr]

test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly exec cat32} {
    exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly exec cat32} {
    exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {pcOnly nt exec cat32} {
    exec [interpreter] more < little | $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {pcOnly nt exec cat32} {
    exec [interpreter] more < big | $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {pcOnly 95 exec cat32} {
    exec command /c type big |& $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
	{pcOnly cat32 AllocConsole} {
    # would block waiting for human input
} {}
test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly exec cat32} {
    exec $cat32 < nul > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly cat32} {
    # doesn't work
} {}
test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \
	{pcOnly exec cat32 .console} {
    exec $cat32 > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.10 {32 bit comprehensive tests: from file handle} \
	{pcOnly exec cat32} {
    set f [open $path(little) r]
    exec $cat32 <@$f > $path(stdout) 2> $path(stderr)
    close $f
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.11 {32 bit comprehensive tests: read from application} \
	{pcOnly exec cat32} {
    set f [open "|[list $cat32] < $path(little)" r]
    gets $f line
    catch {close $f} msg
    list $line $msg
} {little stderr32}
test winpipe-1.12 {32 bit comprehensive tests: a little to file} \
	{pcOnly exec cat32} {
    exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \
	{pcOnly exec cat32} {
    exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \
	{pcOnly exec stdio cat32} {
    exec $cat32 < $path(little) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \
	{pcOnly exec stdio cat32} {
    exec $cat32 < $path(big) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
    list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly exec cat32} {
    catch {exec $cat32 << "You should see this\n" >@stdout} msg
    set msg
} stderr32
test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly exec cat32} {
    # some apps hang when sending a large amount to NUL.  $cat32 isn't one.
    catch {exec $cat32 < $path(big) > nul} msg
    set msg
} stderr32
test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \
	{pcOnly exec cat32 .console} {
    exec $cat32 < $path(big) >&@stdout 
} {}
test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly exec cat32} {
    set f1 [open $path(stdout) w]
    set f2 [open $path(stderr) w]
    exec $cat32 < $path(little) >@$f1 2>@$f2
    close $f1
    close $f2
    list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.20 {32 bit comprehensive tests: write to application} \
	{pcOnly exec cat32} {
    set f [open |[list $cat32 >$path(stdout)] w]
    puts -nonewline $f "foo"
    catch {close $f} msg
    list [contents $path(stdout)] $msg
} {foo stderr32}
test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
	{pcOnly exec cat32} {
    set f [open "|[list $cat32]" r+]
    puts $f $big
    puts $f \032
    flush $f
    set r [read $f 64]
    catch {close $f}
    set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
test winpipe-1.22 {Checking command.com for Win95/98 hanging} {pcOnly 95 exec} {
    exec command.com /c dir /b
    set result 1
} 1
file delete more

test winpipe-4.1 {Tcl_WaitPid} {pcOnly nt exec cat32} {
    proc readResults {f} {
	global x result
	if { [eof $f] } {
	    close $f
	    set x 1
	} else {
	    set line [read $f ]
	    set result "$result$line"
	}
    }

    set f [open "|[list $cat32] < big 2> $path(stderr)" r]
    fconfigure $f  -buffering none -blocking 0
    fileevent $f readable "readResults $f"
    set x 0
    set result ""
    vwait x
    list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"

set path(nothing) [makeFile {} nothing]
close [open $path(nothing) w]

catch {set env_tmp $env(TMP)}
catch {set env_temp $env(TEMP)}

set env(TMP) c:/
set env(TEMP) c:/

test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly exec} {
    set x {}
    set existing [glob -nocomplain c:/tcl*.tmp]
    exec [interpreter] < nothing 
    foreach p [glob -nocomplain c:/tcl*.tmp] {
	if {[lsearch $existing $p] == -1} {
	    lappend x $p
	}
    }
    set x
} {}
test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly exec} {
    set tmp $env(TMP)
    set temp $env(TEMP)
    unset env(TMP)
    unset env(TEMP)
    exec [interpreter] < nothing
    set env(TMP) $tmp
    set env(TEMP) $temp
    set x {}
} {}
test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \
	{pcOnly exec } {
    set tmp $env(TMP)
    set env(TMP) snarky
    exec [interpreter] < nothing
    set env(TMP) $tmp
    set x {}
} {}
test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \
	{pcOnly exec} {
    set tmp $env(TMP)
    set temp $env(TEMP)
    unset env(TMP)
    set env(TEMP) snarky
    exec [interpreter] < nothing
    set env(TMP) $tmp
    set env(TEMP) $temp
    set x {}
} {}

test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \
	{pcOnly exec cat32} {
    set f [open "|[list $cat32]" r+]
    fconfigure $f -blocking 0
    fileevent $f writable { set x writable }
    set x {}
    vwait x
    fileevent $f writable {}
    fileevent $f readable { lappend x readable }
    after 100 { lappend x timeout }
    vwait x
    puts $f foobar
    flush $f
    vwait x
    lappend x [read $f]
    after 100 { lappend x timeout }
    vwait x
    lappend x [catch {close $f} msg] $msg
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
	{pcOnly exec cat32} {
    set f [open "|[list $cat32]" r+]
    fconfigure $f -blocking 0
    fileevent $f writable { set x writable }
    set x {}
    vwait x
    puts -nonewline $f $big$big$big$big
    flush $f
    after 100 { lappend x timeout }
    vwait x
    lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}

set path(echoArgs.tcl) [makeFile {
    puts "[list $argv0 $argv]"
} echoArgs.tcl]

test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly exec} {
    exec [interpreter] $path(echoArgs.tcl) foo "" bar
} [list $path(echoArgs.tcl) {foo {} bar}]
test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly exec} {
    exec [interpreter] $path(echoArgs.tcl) foo \" bar
} [list $path(echoArgs.tcl) {foo {"} bar}]

# restore old values for env(TMP) and env(TEMP)

if {[catch {set env(TMP) $env_tmp}]} {
    unset env(TMP)
}
if {[catch {set env(TEMP) $env_temp}]} {
Changes to tools/genStubs.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.9.8.3 2001/11/11 17:58:00 wolfsuit Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.  
#	
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: genStubs.tcl,v 1.9.8.4 2002/08/20 20:25:29 das Exp $

package require Tcl 8

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#
#	This function is used in the declarations file to declare a new
#	interface entry.
#
# Arguments:
#	index		The index number of the interface.
#	platform	The platform the interface belongs to.  Should be one
#			of generic, win, unix, or mac, or macosx or aqua.
#	decl		The C function declaration, or {} for an undefined
#			entry.
#
# Results:
#	None.

proc genStubs::declare {args} {







|







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#
#	This function is used in the declarations file to declare a new
#	interface entry.
#
# Arguments:
#	index		The index number of the interface.
#	platform	The platform the interface belongs to.  Should be one
#			of generic, win, unix, or mac, or macosx or aqua or x11.
#	decl		The C function declaration, or {} for an undefined
#			entry.
#
# Results:
#	None.

proc genStubs::declare {args} {
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234



235
236
237
238
239
240
241

proc genStubs::addPlatformGuard {plat text} {
    switch $plat {
	win {
	    return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n"
	}
	unix {
	    return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK))/* UNIX */\n${text}#endif /* UNIX */\n"
	}		    
	mac {
	    return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\n"
	}
	macosx {
	    return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
	}
        aqua {
	    return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
	}



    }
    return "$text"
}

# genStubs::emitSlots --
#
#	Generate the stub table slots for the given interface.  If there







|







|


>
>
>







217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

proc genStubs::addPlatformGuard {plat text} {
    switch $plat {
	win {
	    return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n"
	}
	unix {
	    return "#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */\n${text}#endif /* UNIX */\n"
	}		    
	mac {
	    return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\n"
	}
	macosx {
	    return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
	}
	aqua {
	    return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
	}
	x11 {
	    return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n"
	}
    }
    return "$text"
}

# genStubs::emitSlots --
#
#	Generate the stub table slots for the given interface.  If there
618
619
620
621
622
623
624

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
			set emit 1
		    } elseif {$onAll} {
			append text [eval {addPlatformGuard $plat} $skipString]
			set emit 1
		    }
		}
                #

                # "aqua" and "macosx" a special cases, since "macosx" always implies
                # "unix" and "aqua", "macosx", so we need to be careful not to 
                # emit duplicate stubs entries for the two.
                #
		if {[info exists stubs($name,aqua,$i)]
                        && ![info exists stubs($name,macosx,$i)]} {
		    append text [addPlatformGuard aqua \
			    [$slotProc $name $stubs($name,aqua,$i) $i]]
		    set emit 1
		}
		if {[info exists stubs($name,macosx,$i)]
                        && ![info exists stubs($name,unix,$i)]} {
		    append text [addPlatformGuard macosx \
			    [$slotProc $name $stubs($name,macosx,$i) $i]]
		    set emit 1
		}






	    }
	    if {$emit == 0} {
		eval {append text} $skipString
	    }
	}

    } else {
	# Emit separate stubs blocks per platform
	foreach plat {unix win mac} {
	    if {[info exists stubs($name,$plat,lastNum)]} {
		set lastNum $stubs($name,$plat,lastNum)
		set temp {}
		for {set i 0} {$i <= $lastNum} {incr i} {







>
|
|














>
>
>
>
>
>





>







621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
			set emit 1
		    } elseif {$onAll} {
			append text [eval {addPlatformGuard $plat} $skipString]
			set emit 1
		    }
		}
                #
                # "aqua" and "macosx" and "x11" are special cases, 
                # since "macosx" always implies "unix" and "aqua", 
                # "macosx", so we need to be careful not to 
                # emit duplicate stubs entries for the two.
                #
		if {[info exists stubs($name,aqua,$i)]
                        && ![info exists stubs($name,macosx,$i)]} {
		    append text [addPlatformGuard aqua \
			    [$slotProc $name $stubs($name,aqua,$i) $i]]
		    set emit 1
		}
		if {[info exists stubs($name,macosx,$i)]
                        && ![info exists stubs($name,unix,$i)]} {
		    append text [addPlatformGuard macosx \
			    [$slotProc $name $stubs($name,macosx,$i) $i]]
		    set emit 1
		}
		if {[info exists stubs($name,x11,$i)]
                        && ![info exists stubs($name,unix,$i)]} {
		    append text [addPlatformGuard x11 \
			    [$slotProc $name $stubs($name,x11,$i) $i]]
		    set emit 1
		}
	    }
	    if {$emit == 0} {
		eval {append text} $skipString
	    }
	}
	
    } else {
	# Emit separate stubs blocks per platform
	foreach plat {unix win mac} {
	    if {[info exists stubs($name,$plat,lastNum)]} {
		set lastNum $stubs($name,$plat,lastNum)
		set temp {}
		for {set i 0} {$i <= $lastNum} {incr i} {
683
684
685
686
687
688
689










690
691



692
693
694
695
696
697
698
		    eval {append temp} $skipString
		} else {
			append temp [$slotProc $name $stubs($name,macosx,$i) $i]
		    }
		}
		append text [addPlatformGuard macosx $temp]
	    }










    }




}

# genStubs::emitDeclarations --
#
#	This function emits the function declarations for this interface.
#
# Arguments:







>
>
>
>
>
>
>
>
>
>
|
|
>
>
>







694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
		    eval {append temp} $skipString
		} else {
			append temp [$slotProc $name $stubs($name,macosx,$i) $i]
		    }
		}
		append text [addPlatformGuard macosx $temp]
	    }
        # Again, make sure you don't duplicate entries for x11 & unix.
	if {[info exists stubs($name,x11,lastNum)]
                && ![info exists stubs($name,unix,lastNum)]} {
	    set lastNum $stubs($name,x11,lastNum)
	    set temp {}
	    for {set i 0} {$i <= $lastNum} {incr i} {
		if {![info exists stubs($name,x11,$i)]} {
		    eval {append temp} $skipString
		} else {
			append temp [$slotProc $name $stubs($name,x11,$i) $i]
		    }
		}
		append text [addPlatformGuard x11 $temp]
	    }
    }
}

# genStubs::emitDeclarations --
#
#	This function emits the function declarations for this interface.
#
# Arguments:
Changes to tools/man2help.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# man2help.tcl --
#
# This file defines procedures that work in conjunction with the
# man2tcl program to generate a Windows help file from Tcl manual
# entries.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# RCS: @(#) $Id: man2help.tcl,v 1.7.14.2 2002/06/10 05:33:17 wolfsuit Exp $
# 

#
# PASS 1
#

set man2tclprog [file join [file dirname [info script]] man2tcl.exe]








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# man2help.tcl --
#
# This file defines procedures that work in conjunction with the
# man2tcl program to generate a Windows help file from Tcl manual
# entries.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
#
# RCS: @(#) $Id: man2help.tcl,v 1.7.14.3 2002/08/20 20:25:29 das Exp $
# 

#
# PASS 1
#

set man2tclprog [file join [file dirname [info script]] man2tcl.exe]
112
113
114
115
116
117
118

119
120
121
122
123
124
125
126
127
    exit 1
}

set arg 0

if {![string compare [lindex $argv $arg] "-bitmap"]} {
    set bitmap [lindex $argv [incr arg]]

}
set baseName [lindex $argv [incr arg]]
set version [lindex $argv [incr arg]]
set files {}
foreach i [lrange $argv [incr arg] end] {
    set i [file join $i]
    if {[file isdir $i]} {
	foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
	    lappend files $f







>

|







112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
    exit 1
}

set arg 0

if {![string compare [lindex $argv $arg] "-bitmap"]} {
    set bitmap [lindex $argv [incr arg]]
    incr arg
}
set baseName [lindex $argv $arg]
set version [lindex $argv [incr arg]]
set files {}
foreach i [lrange $argv [incr arg] end] {
    set i [file join $i]
    if {[file isdir $i]} {
	foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
	    lappend files $f
Changes to tools/tcl.wse.in.
8
9
10
11
12
13
14
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.4a5
  Disk Filename=setup
  Patch Flags=0000000000000001
  Patch Threshold=85
  Patch Memory=4000
  Variable Name1=_SYS_
  Variable Default1=C:\WINDOWS\SYSTEM
  Variable Flags1=00001000







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
  Japanese Font Size=10
  Start Gradient=0 0 255
  End Gradient=0 0 0
  Windows Flags=00000000000000010010110000001000
  Log Pathname=%MAINDIR%\INSTALL.LOG
  Message Font=MS Sans Serif
  Font Size=8
  Disk Label=tcl8.4b3
  Disk Filename=setup
  Patch Flags=0000000000000001
  Patch Threshold=85
  Patch Memory=4000
  Variable Name1=_SYS_
  Variable Default1=C:\WINDOWS\SYSTEM
  Variable Flags1=00001000
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
end
item: Install File
  Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\win\release\tclreg84.dll
  Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\tclreg84.dll
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\library\dde\pkgIndex.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\pkgIndex.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\win\release\tcldde84.dll
  Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde84.dll
  Flags=0000000000000010
end
item: Install File
  Source=C:\WINNT\SYSTEM32\Msvcrt.dll
  Destination=%MAINDIR%\bin\msvcrt.dll
  Flags=0010001000000011
end







|
|








|
|







1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
end
item: Install File
  Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\win\release\tclreg10.dll
  Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\tclreg10.dll
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\library\dde\pkgIndex.tcl
  Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\pkgIndex.tcl
  Flags=0000000000000010
end
item: Install File
  Source=${__TCLBASEDIR__}\win\release\tcldde12.dll
  Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde12.dll
  Flags=0000000000000010
end
item: Install File
  Source=C:\WINNT\SYSTEM32\Msvcrt.dll
  Destination=%MAINDIR%\bin\msvcrt.dll
  Flags=0010001000000011
end
Changes to unix/Makefile.in.
1
2
3
4
5
6
7
8
9
10



11
12
13
14
15
16
17
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.83.6.4 2002/06/10 05:33:17 wolfsuit 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
# the configuration script).
#----------------------------------------------------------------







|


>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.83.6.5 2002/08/20 20:25:29 das Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#----------------------------------------------------------------
# Things you can change to personalize the Makefile for your own
# site (you can make these changes in either Makefile.in or
# Makefile, but changes to Makefile will get lost if you re-run
# the configuration script).
#----------------------------------------------------------------
133
134
135
136
137
138
139
140
141

142
143
144
145
146
147
148
149
150
151
# To enable memory debugging reverse the comment characters on the following
# lines.  Warning:  if you enable memory debugging, you must do it
# *everywhere*, including all the code that calls Tcl, and you must use
# ckalloc and ckfree everywhere instead of malloc and free.
MEM_DEBUG_FLAGS		=
#MEM_DEBUG_FLAGS	= -DTCL_MEM_DEBUG

# To enable support for stubs in Tcl.
STUB_LIB_FILE		= @TCL_STUB_LIB_FILE@


TCL_STUB_LIB_FILE	= @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE	= libtclstub.a

TCL_STUB_LIB_FLAG	= @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG	= -ltclstub

# To enable compilation debugging reverse the comment characters on
# one of the following lines.
COMPILE_DEBUG_FLAGS	=







<
|
>

|
|







136
137
138
139
140
141
142

143
144
145
146
147
148
149
150
151
152
153
154
# To enable memory debugging reverse the comment characters on the following
# lines.  Warning:  if you enable memory debugging, you must do it
# *everywhere*, including all the code that calls Tcl, and you must use
# ckalloc and ckfree everywhere instead of malloc and free.
MEM_DEBUG_FLAGS		=
#MEM_DEBUG_FLAGS	= -DTCL_MEM_DEBUG


TCL_STUB_LIB_FILE	= @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE	= libtclstub.a

# Generic stub lib name used in rules that apply to tcl and tk
STUB_LIB_FILE		= ${TCL_STUB_LIB_FILE}

TCL_STUB_LIB_FLAG	= @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG	= -ltclstub

# To enable compilation debugging reverse the comment characters on
# one of the following lines.
COMPILE_DEBUG_FLAGS	=
186
187
188
189
190
191
192
193


194
195
196
197






198
199
200
201
202
203
204
205
206
207
208



209
210
211
212
213
214
215
# symbols mean.  The values of the symbols are normally set by the
# configure script.  You shouldn't normally need to modify any of
# these definitions by hand.

STLIB_LD		= @STLIB_LD@
SHLIB_LD		= @SHLIB_LD@
SHLIB_CFLAGS		= @SHLIB_CFLAGS@



SHLIB_SUFFIX		= @SHLIB_SUFFIX@
#SHLIB_SUFFIX		=

DLTEST_TARGETS		= dlpkgs







# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic
# loading is available;  this causes everything in the "dltest"
# subdirectory to be built when making "tcltest.  If dynamic loading
# isn't available, configure defines this symbol to an empty string,
# in which case the shared libraries aren't built.
BUILD_DLTEST		= @BUILD_DLTEST@
#BUILD_DLTEST		=

TCL_LIB_FILE		= @TCL_LIB_FILE@
#TCL_LIB_FILE		= libtcl.a




TCL_LIB_FLAG		= @TCL_LIB_FLAG@
#TCL_LIB_FLAG		= -ltcl

TCL_EXP_FILE		= @TCL_EXP_FILE@
TCL_BUILD_EXP_FILE	= @TCL_BUILD_EXP_FILE@








|
>
>



|
>
>
>
>
>
>











>
>
>







189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
# symbols mean.  The values of the symbols are normally set by the
# configure script.  You shouldn't normally need to modify any of
# these definitions by hand.

STLIB_LD		= @STLIB_LD@
SHLIB_LD		= @SHLIB_LD@
SHLIB_CFLAGS		= @SHLIB_CFLAGS@
SHLIB_LD_FLAGS		= @SHLIB_LD_FLAGS@
SHLIB_LD_LIBS		= @SHLIB_LD_LIBS@
TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@
SHLIB_SUFFIX		= @SHLIB_SUFFIX@
#SHLIB_SUFFIX		=

DLTEST_TARGETS		= dltest.marker

# Additional search flags needed to find the various shared libraries
# at run-time.  The first symbol is for use when creating a binary
# with cc, and the second is for use when running ld directly.
CC_SEARCH_FLAGS	= @CC_SEARCH_FLAGS@
LD_SEARCH_FLAGS	= @LD_SEARCH_FLAGS@

# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic
# loading is available;  this causes everything in the "dltest"
# subdirectory to be built when making "tcltest.  If dynamic loading
# isn't available, configure defines this symbol to an empty string,
# in which case the shared libraries aren't built.
BUILD_DLTEST		= @BUILD_DLTEST@
#BUILD_DLTEST		=

TCL_LIB_FILE		= @TCL_LIB_FILE@
#TCL_LIB_FILE		= libtcl.a

# Generic lib name used in rules that apply to tcl and tk
LIB_FILE		= ${TCL_LIB_FILE}

TCL_LIB_FLAG		= @TCL_LIB_FLAG@
#TCL_LIB_FLAG		= -ltcl

TCL_EXP_FILE		= @TCL_EXP_FILE@
TCL_BUILD_EXP_FILE	= @TCL_BUILD_EXP_FILE@

227
228
229
230
231
232
233
234
235
236
237
238
239
240
241













242
243
244
245
246
247
248
SRC_DIR			= @srcdir@
TOP_DIR			= @srcdir@/..
GENERIC_DIR		= $(TOP_DIR)/generic
COMPAT_DIR		= $(TOP_DIR)/compat
TOOL_DIR		= $(TOP_DIR)/tools
UNIX_DIR		= $(TOP_DIR)/unix
MAC_OSX_DIR		= $(TOP_DIR)/macosx

# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR		= @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY	= @TCL_SRC_DIR@/library

CC			= @CC@
#CC			= purify -best-effort @CC@ -DPURIFY














#----------------------------------------------------------------
# The information below should be usable as is.  The configure
# script won't modify it and you shouldn't need to modify it
# either.
#----------------------------------------------------------------








<







>
>
>
>
>
>
>
>
>
>
>
>
>







241
242
243
244
245
246
247

248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
SRC_DIR			= @srcdir@
TOP_DIR			= @srcdir@/..
GENERIC_DIR		= $(TOP_DIR)/generic
COMPAT_DIR		= $(TOP_DIR)/compat
TOOL_DIR		= $(TOP_DIR)/tools
UNIX_DIR		= $(TOP_DIR)/unix
MAC_OSX_DIR		= $(TOP_DIR)/macosx

# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR		= @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY	= @TCL_SRC_DIR@/library

CC			= @CC@
#CC			= purify -best-effort @CC@ -DPURIFY

# Flags to be passed to mkLinks to control whether the manpages
# should be compressed and linked with softlinks
MKLINKS_FLAGS           = @MKLINKS_FLAGS@

#----------------------------------------------------------------
# The information below is usually usable as is.  The configure
# script won't modify it and it only exists to make working
# around selected rare system configurations easier.
#----------------------------------------------------------------

GDB			= gdb
DDD			= ddd

#----------------------------------------------------------------
# The information below should be usable as is.  The configure
# script won't modify it and you shouldn't need to modify it
# either.
#----------------------------------------------------------------

400
401
402
403
404
405
406
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
	$(UNIX_DIR)/tclLoadDl2.c \
	$(UNIX_DIR)/tclLoadDld.c \
	$(UNIX_DIR)/tclLoadDyld.c \
	$(GENERIC_DIR)/tclLoadNone.c \
	$(UNIX_DIR)/tclLoadOSF.c \
	$(UNIX_DIR)/tclLoadShl.c

MACOSX_SRCS =


# Note: don't include DL_SRCS or MACOSX_SRCS in SRCS: most of those
# files won't compile on the current machine, and they will cause
# problems for things like "make depend".

SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(STUB_SRCS)

all: binaries libraries doc

binaries: ${TCL_LIB_FILE} $(TCL_STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh

libraries:

doc:

# The following target is configured by autoconf to generate either
# a shared library or non-shared library for Tcl.
${TCL_LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
	rm -f ${TCL_LIB_FILE}
	@MAKE_LIB@
	if test "x@DL_OBJS@" = "xtclLoadAout.o"; then \
		$(RANLIB) ${TCL_LIB_FILE}; \
	fi

${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
	rm -f ${STUB_LIB_FILE}
	@MAKE_STUB_LIB@
	$(RANLIB) ${STUB_LIB_FILE}

# Make target which outputs the list of the .o contained in the Tcl lib
# usefull to build a single big shared library containing Tcl and other
# extensions.  used for the Tcl Plugin.  -- dl
# The dependency on OBJS is not there because we just want the list
# of objects here, not actually building them
tclLibObjs:
	@echo ${OBJS}
# This targets actually build the objects needed for the lib in the above
# case
objs: ${OBJS}


tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
	${CC} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
		@TCL_LD_SEARCH_FLAGS@ -o tclsh






# Resetting the LIB_RUNTIME_DIR below is required so that
# the generated tcltest executable gets the build directory
# burned into its ld search path. This keeps tcltest from
# picking up an already installed version of the Tcl library.

tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST}
	$(MAKE) tcltest-real LIB_RUNTIME_DIR=`pwd`

tcltest-real:
	${CC} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
		@TCL_LD_SEARCH_FLAGS@ -o tcltest

# Note, in the target below TCL_LIBRARY needs to be set or else
# "make test" won't work in the case where the compilation directory
# isn't the same as the source directory.
# Specifying TESTFLAGS on the command line is the standard way to pass
# args to tcltest, ie:
#	% make test TESTFLAGS="-verbose bps -file fileName.test"







|
|









|







|
|

<
<
<


|

<















|
>
>
>
>
>











|







426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454



455
456
457
458

459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
	$(UNIX_DIR)/tclLoadDl2.c \
	$(UNIX_DIR)/tclLoadDld.c \
	$(UNIX_DIR)/tclLoadDyld.c \
	$(GENERIC_DIR)/tclLoadNone.c \
	$(UNIX_DIR)/tclLoadOSF.c \
	$(UNIX_DIR)/tclLoadShl.c

MACOSX_SRCS = \
	$(MAC_OSX_DIR)/tclMacOSXBundle.c

# Note: don't include DL_SRCS or MACOSX_SRCS in SRCS: most of those
# files won't compile on the current machine, and they will cause
# problems for things like "make depend".

SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(STUB_SRCS)

all: binaries libraries doc

binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh

libraries:

doc:

# The following target is configured by autoconf to generate either
# a shared library or non-shared library for Tcl.
${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
	rm -f $@
	@MAKE_LIB@




${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
	rm -f $@
	@MAKE_STUB_LIB@


# Make target which outputs the list of the .o contained in the Tcl lib
# usefull to build a single big shared library containing Tcl and other
# extensions.  used for the Tcl Plugin.  -- dl
# The dependency on OBJS is not there because we just want the list
# of objects here, not actually building them
tclLibObjs:
	@echo ${OBJS}
# This targets actually build the objects needed for the lib in the above
# case
objs: ${OBJS}


tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
	${CC} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
		${CC_SEARCH_FLAGS} -o tclsh

# Resetting the LIB_RUNTIME_DIR below is required so that
# the generated tcltest executable gets the build directory
# burned into its ld search path. This keeps tcltest from
# picking up an already installed version of the Tcl library.

# Resetting the LIB_RUNTIME_DIR below is required so that
# the generated tcltest executable gets the build directory
# burned into its ld search path. This keeps tcltest from
# picking up an already installed version of the Tcl library.

tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST}
	$(MAKE) tcltest-real LIB_RUNTIME_DIR=`pwd`

tcltest-real:
	${CC} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
		${CC_SEARCH_FLAGS} -o tcltest

# Note, in the target below TCL_LIBRARY needs to be set or else
# "make test" won't work in the case where the compilation directory
# isn't the same as the source directory.
# Specifying TESTFLAGS on the command line is the standard way to pass
# args to tcltest, ie:
#	% make test TESTFLAGS="-verbose bps -file fileName.test"
481
482
483
484
485
486
487










488
489
490
491
492
493
494
495
496
497
498






499



500
501
502
503
504
505
506
507
508
509
510
runtest: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
	SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tcltest











# This target can be used to run tclsh from the build directory
# via `make shell SCRIPT=/tmp/foo.tcl`
shell: tclsh
	@@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
	SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(SCRIPT)

# This target can be used to run tclsh inside either gdb or insight
gdb: tclsh






	@echo "set env LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}" > gdb.run



	@echo "set env LIBPATH=`pwd`:${LIBPATH}" >> gdb.run
	@echo "set env SHLIB_PATH=`pwd`:${SHLIB_PATH}" >> gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	gdb ./tclsh --command=gdb.run
	rm gdb.run

# 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).







>
>
>
>
>
>
>
>
>
>











>
>
>
>
>
>
|
>
>
>



|







508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
runtest: tcltest
	@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
	SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tcltest

# Useful target for running the test suite with an unwritable current
# directory...
ro-test: tcltest
	LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
	DYLD_LIBRARY_PATH=`pwd`:${DYLD_LIBRARY_PATH}; export DYLD_LIBRARY_PATH; \
	LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
	SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest

# This target can be used to run tclsh from the build directory
# via `make shell SCRIPT=/tmp/foo.tcl`
shell: tclsh
	@@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
	LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
	SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
	TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
	./tclsh $(SCRIPT)

# This target can be used to run tclsh inside either gdb or insight
gdb: tclsh
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env LIBPATH=`pwd`:${LIBPATH}" >> gdb.run
	@echo "set env SHLIB_PATH=`pwd`:${SHLIB_PATH}" >> gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	$(GDB) ./tclsh --command=gdb.run
	rm gdb.run

# This target can be used to run tclsh inside ddd
ddd: tclsh
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env LIBPATH=`pwd`:${LIBPATH}" >> gdb.run
	@echo "set env SHLIB_PATH=`pwd`:${SHLIB_PATH}" >> gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	$(DDD) -command=gdb.run ./tclsh
	rm gdb.run

# The following target outputs the name of the top-level source directory
# for Tcl (it is used by Tk's configure script, for example).  The
# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake".
# Note: this target is now obsolete (use the autoconf variable
# TCL_SRC_DIR from tclConfig.sh instead).
525
526
527
528
529
530
531
532
533
534
535

536
537
538
539
540
541
542
543
544
	    -e 's?SCCSID?RCS: @(#) ?' \
	    -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
	    -e '/TclDatenewstate:/d' -e '/#pragma/d' \
	    -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \
	    <y.tab.c >$(GENERIC_DIR)/tclDate.c
	rm y.tab.c

# The following targets generate 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.


dlpkgs:
	cd dltest ; $(MAKE)

install: install-binaries install-libraries install-doc

install-strip:
	$(MAKE) install \
		INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \







|


|
>

|







571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
	    -e 's?SCCSID?RCS: @(#) ?' \
	    -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
	    -e '/TclDatenewstate:/d' -e '/#pragma/d' \
	    -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \
	    <y.tab.c >$(GENERIC_DIR)/tclDate.c
	rm y.tab.c

# The following target generates the shared libraries in dltest/ that
# are used for testing;  they are included as part of the "tcltest"
# target (via the BUILD_DLTEST variable) if dynamic loading is supported
# on this platform. The Makefile in the dltest subdirectory creates
# the dltest.marker file in this directory after a successful build.

dltest.marker:
	cd dltest ; $(MAKE)

install: install-binaries install-libraries install-doc

install-strip:
	$(MAKE) install \
		INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
557
558
559
560
561
562
563
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
		chmod 755 $$i; \
		else true; \
		fi; \
	    done;
	@if test ! -x $(SRC_DIR)/install-sh; then \
	    chmod +x $(SRC_DIR)/install-sh; \
	    fi
	@echo "Installing $(TCL_LIB_FILE) to $(LIB_INSTALL_DIR)/"
	@$(INSTALL_LIBRARY) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE)
	@if test "x@DL_OBJS@" = "xtclLoadAout.o"; then \
	    (cd $(LIB_INSTALL_DIR); $(RANLIB) $(TCL_LIB_FILE)); \
	    fi
	@chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE)
	@if test "$(TCL_BUILD_EXP_FILE)" != ""; then \
	    echo "Installing $(TCL_EXP_FILE) to $(LIB_INSTALL_DIR)/"; \
	    $(INSTALL_DATA) $(TCL_BUILD_EXP_FILE) \
			$(LIB_INSTALL_DIR)/$(TCL_EXP_FILE); \
	    fi
	@echo "Installing tclsh as $(BIN_INSTALL_DIR)/tclsh$(VERSION)"
	@$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION)
	@echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/"
	@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
	@if test "$(TCL_STUB_LIB_FILE)" != "" ; then \
	    echo "Installing $(TCL_STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
	    $(INSTALL_LIBRARY) $(STUB_LIB_FILE) \
			 $(LIB_INSTALL_DIR)/$(TCL_STUB_LIB_FILE); \
	    fi

install-libraries: libraries
	@for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \
	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		mkdir -p $$i; \
		chmod 755 $$i; \
		else true; \
		fi; \
	    done;
	@for i in http2.4 http1.0 opt0.4 encoding msgcat1.2 tcltest2.0; \
	    do \
	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
		mkdir -p $(SCRIPT_INSTALL_DIR)/$$i; \
		chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \
		else true; \
		fi; \







|
|
<
<
<
|









|
|
|
<
|











|







604
605
606
607
608
609
610
611
612



613
614
615
616
617
618
619
620
621
622
623
624
625

626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
		chmod 755 $$i; \
		else true; \
		fi; \
	    done;
	@if test ! -x $(SRC_DIR)/install-sh; then \
	    chmod +x $(SRC_DIR)/install-sh; \
	    fi
	@echo "Installing $(LIB_FILE) to $(LIB_INSTALL_DIR)/"
	@@INSTALL_LIB@



	@chmod 555 $(LIB_INSTALL_DIR)/$(LIB_FILE)
	@if test "$(TCL_BUILD_EXP_FILE)" != ""; then \
	    echo "Installing $(TCL_EXP_FILE) to $(LIB_INSTALL_DIR)/"; \
	    $(INSTALL_DATA) $(TCL_BUILD_EXP_FILE) \
			$(LIB_INSTALL_DIR)/$(TCL_EXP_FILE); \
	    fi
	@echo "Installing tclsh as $(BIN_INSTALL_DIR)/tclsh$(VERSION)"
	@$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION)
	@echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/"
	@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
	@if test "$(STUB_LIB_FILE)" != "" ; then \
	    echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
	    @INSTALL_STUB_LIB@ ; \

	fi

install-libraries: libraries
	@for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \
	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		mkdir -p $$i; \
		chmod 755 $$i; \
		else true; \
		fi; \
	    done;
	@for i in http2.4 http1.0 opt0.4 encoding msgcat1.3 tcltest2.2; \
	    do \
	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
		mkdir -p $(SCRIPT_INSTALL_DIR)/$$i; \
		chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \
		else true; \
		fi; \
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.4; \
	    done;
	@echo "Installing library opt0.4 directory";
	@for j in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \
	    done;
	@echo "Installing library msgcat1.2 directory";
	@for j in $(TOP_DIR)/library/msgcat/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/msgcat1.2; \
	    done;
	@echo "Installing library tcltest2.0 directory";
	@for j in $(TOP_DIR)/library/tcltest/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/tcltest2.0; \
	    done;
	@echo "Installing library encoding directory";
	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
		$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \
	done;

install-doc: doc







|


|

|


|







669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.4; \
	    done;
	@echo "Installing library opt0.4 directory";
	@for j in $(TOP_DIR)/library/opt/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \
	    done;
	@echo "Installing library msgcat1.3 directory";
	@for j in $(TOP_DIR)/library/msgcat/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/msgcat1.3; \
	    done;
	@echo "Installing library tcltest2.2 directory";
	@for j in $(TOP_DIR)/library/tcltest/*.tcl ; \
	    do \
	    $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/tcltest2.2; \
	    done;
	@echo "Installing library encoding directory";
	@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
		$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \
	done;

install-doc: doc
663
664
665
666
667
668
669
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
	    do \
	    rm -f $(MAN1_INSTALL_DIR)/$$i; \
	    sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
		    $$i > $(MAN1_INSTALL_DIR)/$$i; \
	    chmod 444 $(MAN1_INSTALL_DIR)/$$i; \
	    done;
	@echo "Cross-linking top-level (.1) docs";
	@$(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR)
	@echo "Installing C API (.3) docs";
	@cd $(TOP_DIR)/doc; for i in *.3; \
	    do \
	    rm -f $(MAN3_INSTALL_DIR)/$$i; \
	    sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
		    $$i > $(MAN3_INSTALL_DIR)/$$i; \
	    chmod 444 $(MAN3_INSTALL_DIR)/$$i; \
	    done;
	@echo "Cross-linking C API (.3) docs";
	@$(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR)
	@echo "Installing command (.n) docs";
	@cd $(TOP_DIR)/doc; for i in *.n; \
	    do \
	    rm -f $(MANN_INSTALL_DIR)/$$i; \
	    sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
		    $$i > $(MANN_INSTALL_DIR)/$$i; \
	    chmod 444 $(MANN_INSTALL_DIR)/$$i; \
	    done;
	@echo "Cross-linking command (.n) docs";
	@$(UNIX_DIR)/mkLinks $(MANN_INSTALL_DIR)

Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
	$(SHELL) config.status

clean:
	rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
		errors tclsh tcltest lib.exp







|









|









|







706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
	    do \
	    rm -f $(MAN1_INSTALL_DIR)/$$i; \
	    sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
		    $$i > $(MAN1_INSTALL_DIR)/$$i; \
	    chmod 444 $(MAN1_INSTALL_DIR)/$$i; \
	    done;
	@echo "Cross-linking top-level (.1) docs";
	@$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MAN1_INSTALL_DIR)
	@echo "Installing C API (.3) docs";
	@cd $(TOP_DIR)/doc; for i in *.3; \
	    do \
	    rm -f $(MAN3_INSTALL_DIR)/$$i; \
	    sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
		    $$i > $(MAN3_INSTALL_DIR)/$$i; \
	    chmod 444 $(MAN3_INSTALL_DIR)/$$i; \
	    done;
	@echo "Cross-linking C API (.3) docs";
	@$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MAN3_INSTALL_DIR)
	@echo "Installing command (.n) docs";
	@cd $(TOP_DIR)/doc; for i in *.n; \
	    do \
	    rm -f $(MANN_INSTALL_DIR)/$$i; \
	    sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
		    $$i > $(MANN_INSTALL_DIR)/$$i; \
	    chmod 444 $(MANN_INSTALL_DIR)/$$i; \
	    done;
	@echo "Cross-linking command (.n) docs";
	@$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MANN_INSTALL_DIR)

Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
	$(SHELL) config.status

clean:
	rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
		errors tclsh tcltest lib.exp
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
# purely for documentation purposes so people who are interested in
# the Xt based notifier can modify them to suit their own installation.

xttest:  ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
	@DL_OBJS@ ${BUILD_DLTEST}
	${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
		@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
		@TCL_LD_SEARCH_FLAGS@ -L/usr/openwin/lib -lXt -o xttest

tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c
	$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \
		$(UNIX_DIR)/tclXtNotify.c

tclXtTest.o: $(UNIX_DIR)/tclXtTest.c
	$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \







|







1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
# purely for documentation purposes so people who are interested in
# the Xt based notifier can modify them to suit their own installation.

xttest:  ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
	@DL_OBJS@ ${BUILD_DLTEST}
	${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
		@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
		${CC_SEARCH_FLAGS} -L/usr/openwin/lib -lXt -o xttest

tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c
	$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \
		$(UNIX_DIR)/tclXtNotify.c

tclXtTest.o: $(UNIX_DIR)/tclXtTest.c
	$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \
1085
1086
1087
1088
1089
1090
1091

1092

1093
1094
1095
1096
1097
1098
1099

#
# Target to regenerate header files and stub files from the *.decls tables.
#

$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
		$(GENERIC_DIR)/tclInt.decls

	@echo "Warning: run \"make genstubs\" to regenerate tclStubInit.c"


genstubs:
	$(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
		$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls

#
# Target to check that all exported functions have an entry in the stubs







>
|
>







1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144

#
# Target to regenerate header files and stub files from the *.decls tables.
#

$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
		$(GENERIC_DIR)/tclInt.decls
	@echo "Warning: tclStubInit.c may be out of date."
	@echo "Developers may want to run \"make genstubs\" to regenerate."
	@echo "This warning can be safely ignored, do not report as a bug!"

genstubs:
	$(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
		$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls

#
# Target to check that all exported functions have an entry in the stubs
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
#
# Target to create a proper Tcl distribution from information in the
# master source directory.  DISTDIR must be defined to indicate where
# to put the distribution.
#

DISTROOT = /tmp/dist
DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@
ZIPNAME	 = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip
DISTDIR	 = $(DISTROOT)/$(DISTNAME)
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in
	autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure

dist: $(UNIX_DIR)/configure mklinks
	rm -rf $(DISTDIR)
	mkdir -p $(DISTDIR)/unix







|
|







1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
#
# Target to create a proper Tcl distribution from information in the
# master source directory.  DISTDIR must be defined to indicate where
# to put the distribution.
#

DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME	 = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}.zip
DISTDIR	 = $(DISTROOT)/$(DISTNAME)
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in
	autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure

dist: $(UNIX_DIR)/configure mklinks
	rm -rf $(DISTDIR)
	mkdir -p $(DISTDIR)/unix
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
		$(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \
		$(DISTDIR)/compat
	mkdir $(DISTDIR)/tests
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests
	cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
		$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
		$(DISTDIR)/tests
	mkdir $(DISTDIR)/tests/pkg
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests/pkg
	cp -p $(TOP_DIR)/tests/pkg/*.tcl $(DISTDIR)/tests/pkg
	mkdir $(DISTDIR)/win
	cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
	cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \
		$(TOP_DIR)/win/tclConfig.sh.in \
		$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
		$(DISTDIR)/win
	cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h \







<
<
<







1264
1265
1266
1267
1268
1269
1270



1271
1272
1273
1274
1275
1276
1277
		$(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/README \
		$(DISTDIR)/compat
	mkdir $(DISTDIR)/tests
	cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests
	cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
		$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
		$(DISTDIR)/tests



	mkdir $(DISTDIR)/win
	cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
	cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \
		$(TOP_DIR)/win/tclConfig.sh.in \
		$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
		$(DISTDIR)/win
	cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h \
Changes to unix/README.
1
2
3
4
5
6
7
8
9
10
11
Tcl UNIX README
---------------

RCS: @(#) $Id: README,v 1.17.8.2 2002/06/10 05:33:17 wolfsuit Exp $

This is the directory where you configure, compile, test, and install
UNIX versions of Tcl.  This directory also contains source files for Tcl
that are specific to UNIX.  Some of the files in this directory are
used on the PC or Mac platform too, but they all depend on UNIX
(POSIX/ANSI C) interfaces and some of them only make sense under UNIX.




|







1
2
3
4
5
6
7
8
9
10
11
Tcl UNIX README
---------------

RCS: @(#) $Id: README,v 1.17.8.3 2002/08/20 20:25:29 das Exp $

This is the directory where you configure, compile, test, and install
UNIX versions of Tcl.  This directory also contains source files for Tcl
that are specific to UNIX.  Some of the files in this directory are
used on the PC or Mac platform too, but they all depend on UNIX
(POSIX/ANSI C) interfaces and some of them only make sense under UNIX.

69
70
71
72
73
74
75




76
77
78
79
80
81
82
	--enable-64bit-vis	enable 64bit Sparc VIS support
	--disable-64bit-vis	disable 64bit Sparc VIS support
	--enable-langinfo	Allows use of modern nl_langinfo check for
				better localization support.  This is on by
				default on platforms where nl_langinfo is
				found.
	--disable-langinfo	Specifically disables use of nl_langinfo.





    Note: by default gcc will be used if it can be located on the PATH.
    if you want to use cc instead of gcc, set the CC environment variable
    to "cc" before running configure. It is not safe to edit the
    Makefile to use gcc after configure is run.

    Note: be sure to use only absolute path names (those starting with "/")







>
>
>
>







69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
	--enable-64bit-vis	enable 64bit Sparc VIS support
	--disable-64bit-vis	disable 64bit Sparc VIS support
	--enable-langinfo	Allows use of modern nl_langinfo check for
				better localization support.  This is on by
				default on platforms where nl_langinfo is
				found.
	--disable-langinfo	Specifically disables use of nl_langinfo.
	--enable-man-symlinks	Use symlinks for linking the manpages that
				should be reachable under several names.
	--enable-man-compression=PROG
				Compress the manpages using PROG.

    Note: by default gcc will be used if it can be located on the PATH.
    if you want to use cc instead of gcc, set the CC environment variable
    to "cc" before running configure. It is not safe to edit the
    Makefile to use gcc after configure is run.

    Note: be sure to use only absolute path names (those starting with "/")
Changes to unix/configure.
8
9
10
11
12
13
14





15
16
17
18


19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
# gives unlimited permission to copy, distribute and modify it.

# Defaults:
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help





  --enable-threads        build with threads"
ac_help="$ac_help
  --enable-langinfo	  use nl_langinfo if possible to determine
			  encoding at startup, otherwise use old heuristic"


ac_help="$ac_help
  --enable-64bit          enable 64bit support (where applicable)"
ac_help="$ac_help
  --enable-64bit-vis      enable 64bit Sparc VIS support"
ac_help="$ac_help
  --disable-load          disallow dynamic loading and "load" command"
ac_help="$ac_help
  --enable-symbols        build with debugging symbols [--disable-symbols]"
ac_help="$ac_help
  --enable-shared         build and link with shared libraries [--enable-shared]"
ac_help="$ac_help
  --enable-framework        package shared libraries in frameworks [--enable-framework]"

# Initialize some variables set by options.
# The variables have the same names as the options, with
# dashes changed to underlines.
build=NONE
cache_file=./config.cache
exec_prefix=NONE







>
>
>
>
>




>
>









<
<
|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34


35
36
37
38
39
40
41
42
# gives unlimited permission to copy, distribute and modify it.

# Defaults:
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help
  --enable-man-symlinks   use symlinks for the manpages"
ac_help="$ac_help
  --enable-man-compression=PROG
                          compress the manpages with PROG"
ac_help="$ac_help
  --enable-threads        build with threads"
ac_help="$ac_help
  --enable-langinfo	  use nl_langinfo if possible to determine
			  encoding at startup, otherwise use old heuristic"
ac_help="$ac_help
  --enable-shared         build and link with shared libraries [--enable-shared]"
ac_help="$ac_help
  --enable-64bit          enable 64bit support (where applicable)"
ac_help="$ac_help
  --enable-64bit-vis      enable 64bit Sparc VIS support"
ac_help="$ac_help
  --disable-load          disallow dynamic loading and "load" command"
ac_help="$ac_help
  --enable-symbols        build with debugging symbols [--disable-symbols]"
ac_help="$ac_help


  --enable-framework      package shared libraries in frameworks [--disable-framework]"

# Initialize some variables set by options.
# The variables have the same names as the options, with
# dashes changed to underlines.
build=NONE
cache_file=./config.cache
exec_prefix=NONE
534
535
536
537
538
539
540

541
542
543
544
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
    ac_n=-n ac_c= ac_t=
  fi
else
  ac_n= ac_c='\c' ac_t=
fi




TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="a5"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`


































#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------

# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
    CFLAGS=""
fi

# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:576: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







>




|















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>














|







539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
    ac_n=-n ac_c= ac_t=
  fi
else
  ac_n= ac_c='\c' ac_t=
fi




TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="b3"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`

#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------


	echo $ac_n "checking whether to use symlinks for manpages""... $ac_c" 1>&6
echo "configure:575: checking whether to use symlinks for manpages" >&5
	# Check whether --enable-man-symlinks or --disable-man-symlinks was given.
if test "${enable_man_symlinks+set}" = set; then
  enableval="$enable_man_symlinks"
  test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --symlinks"
else
  enableval="no"
fi

	echo "$ac_t""$enableval" 1>&6

	echo $ac_n "checking compression for manpages""... $ac_c" 1>&6
echo "configure:587: checking compression for manpages" >&5
	# Check whether --enable-man-compression or --disable-man-compression was given.
if test "${enable_man_compression+set}" = set; then
  enableval="$enable_man_compression"
  test "$enableval" = "yes" && echo && { echo "configure: error: missing argument to --enable-man-compression" 1>&2; exit 1; }
		test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --compress $enableval"
else
  enableval="no"
fi

	echo "$ac_t""$enableval" 1>&6

	


#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------

# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
    CFLAGS=""
fi

# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:615: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
  echo "$ac_t""no" 1>&6
fi

if test -z "$CC"; then
  # Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:606: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
  echo "$ac_t""no" 1>&6
fi

if test -z "$CC"; then
  # Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:645: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663

  if test -z "$CC"; then
    case "`uname -s`" in
    *win32* | *WIN32*)
      # Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:657: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







688
689
690
691
692
693
694
695
696
697
698
699
700
701
702

  if test -z "$CC"; then
    case "`uname -s`" in
    *win32* | *WIN32*)
      # Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:696: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
 ;;
    esac
  fi
  test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi

echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
echo "configure:689: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5

ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross

cat > conftest.$ac_ext << EOF

#line 700 "configure"
#include "confdefs.h"

main(){return(0);}
EOF
if { (eval echo configure:705: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  ac_cv_prog_cc_works=yes
  # If we can't run a trivial program, we are probably using a cross compiler.
  if (./conftest; exit) 2>/dev/null; then
    ac_cv_prog_cc_cross=no
  else
    ac_cv_prog_cc_cross=yes
  fi







|










|




|







720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
 ;;
    esac
  fi
  test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi

echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
echo "configure:728: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5

ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross

cat > conftest.$ac_ext << EOF

#line 739 "configure"
#include "confdefs.h"

main(){return(0);}
EOF
if { (eval echo configure:744: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  ac_cv_prog_cc_works=yes
  # If we can't run a trivial program, we are probably using a cross compiler.
  if (./conftest; exit) 2>/dev/null; then
    ac_cv_prog_cc_cross=no
  else
    ac_cv_prog_cc_cross=yes
  fi
723
724
725
726
727
728
729
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
cross_compiling=$ac_cv_prog_cc_cross

echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
if test $ac_cv_prog_cc_works = no; then
  { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
echo "configure:731: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross

echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
echo "configure:736: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.c <<EOF
#ifdef __GNUC__
  yes;
#endif
EOF
if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:745: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
  ac_cv_prog_gcc=yes
else
  ac_cv_prog_gcc=no
fi
fi

echo "$ac_t""$ac_cv_prog_gcc" 1>&6

if test $ac_cv_prog_gcc = yes; then
  GCC=yes
else
  GCC=
fi

ac_test_CFLAGS="${CFLAGS+set}"
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
echo "configure:764: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
  ac_cv_prog_cc_g=yes
else







|




|








|


















|







762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
cross_compiling=$ac_cv_prog_cc_cross

echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
if test $ac_cv_prog_cc_works = no; then
  { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
echo "configure:770: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross

echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
echo "configure:775: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.c <<EOF
#ifdef __GNUC__
  yes;
#endif
EOF
if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:784: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
  ac_cv_prog_gcc=yes
else
  ac_cv_prog_gcc=no
fi
fi

echo "$ac_t""$ac_cv_prog_gcc" 1>&6

if test $ac_cv_prog_gcc = yes; then
  GCC=yes
else
  GCC=
fi

ac_test_CFLAGS="${CFLAGS+set}"
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
echo "configure:803: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
  ac_cv_prog_cc_g=yes
else
787
788
789
790
791
792
793
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
  if test "$GCC" = yes; then
    CFLAGS="-O2"
  else
    CFLAGS=
  fi
fi

# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:798: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$RANLIB"; then
  ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
  ac_dummy="$PATH"
  for ac_dir in $ac_dummy; do
    test -z "$ac_dir" && ac_dir=.
    if test -f $ac_dir/$ac_word; then
      ac_cv_prog_RANLIB="ranlib"
      break
    fi
  done
  IFS="$ac_save_ifs"
  test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
fi
fi
RANLIB="$ac_cv_prog_RANLIB"
if test -n "$RANLIB"; then
  echo "$ac_t""$RANLIB" 1>&6
else
  echo "$ac_t""no" 1>&6
fi

echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:826: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
  CPP=
fi
if test -z "$CPP"; then
if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
    # This must be in double quotes, not single quotes, because CPP may get
  # substituted into the Makefile and "${CC-cc}" will confuse make.
  CPP="${CC-cc} -E"
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp.
  cat > conftest.$ac_ext <<EOF
#line 841 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:847: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -E -traditional-cpp"
  cat > conftest.$ac_ext <<EOF
#line 858 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:864: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -nologo -E"
  cat > conftest.$ac_ext <<EOF
#line 875 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:881: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|














|





|










|





|










|





|







826
827
828
829
830
831
832






























833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
  if test "$GCC" = yes; then
    CFLAGS="-O2"
  else
    CFLAGS=
  fi
fi































echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:835: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
  CPP=
fi
if test -z "$CPP"; then
if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
    # This must be in double quotes, not single quotes, because CPP may get
  # substituted into the Makefile and "${CC-cc}" will confuse make.
  CPP="${CC-cc} -E"
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp.
  cat > conftest.$ac_ext <<EOF
#line 850 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:856: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -E -traditional-cpp"
  cat > conftest.$ac_ext <<EOF
#line 867 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:873: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -nologo -E"
  cat > conftest.$ac_ext <<EOF
#line 884 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:890: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
fi
echo "$ac_t""$CPP" 1>&6

for ac_hdr in unistd.h limits.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:909: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 914 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:919: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
fi
echo "$ac_t""$CPP" 1>&6

for ac_hdr in unistd.h limits.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:918: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 923 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:928: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958

#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------


    echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:952: checking for building with threads" >&5
    # Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
  enableval="$enable_threads"
  tcl_ok=$enableval
else
  tcl_ok=no
fi







|







953
954
955
956
957
958
959
960
961
962
963
964
965
966
967

#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------


    echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:961: checking for building with threads" >&5
    # Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
  enableval="$enable_threads"
  tcl_ok=$enableval
else
  tcl_ok=no
fi
976
977
978
979
980
981
982
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
EOF

	cat >> confdefs.h <<\EOF
#define _THREAD_SAFE 1
EOF

	echo $ac_n "checking for pthread_mutex_init in -lpthread""... $ac_c" 1>&6
echo "configure:984: checking for pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lpthread  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 992 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1003: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
EOF

	cat >> confdefs.h <<\EOF
#define _THREAD_SAFE 1
EOF

	echo $ac_n "checking for pthread_mutex_init in -lpthread""... $ac_c" 1>&6
echo "configure:993: checking for pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lpthread  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1001 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1012: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
1023
1024
1025
1026
1027
1028
1029
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
	if test "$tcl_ok" = "no"; then
	    # Check a little harder for __pthread_mutex_init in the same
	    # library, as some systems hide it there until pthread.h is
	    # defined.  We could alternatively do an AC_TRY_COMPILE with
	    # pthread.h, but that will work with libpthread really doesn't
	    # exist, like AIX 4.2.  [Bug: 4359]
	    echo $ac_n "checking for __pthread_mutex_init in -lpthread""... $ac_c" 1>&6
echo "configure:1031: checking for __pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'__pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lpthread  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1039 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char __pthread_mutex_init();

int main() {
__pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1050: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
	if test "$tcl_ok" = "no"; then
	    # Check a little harder for __pthread_mutex_init in the same
	    # library, as some systems hide it there until pthread.h is
	    # defined.  We could alternatively do an AC_TRY_COMPILE with
	    # pthread.h, but that will work with libpthread really doesn't
	    # exist, like AIX 4.2.  [Bug: 4359]
	    echo $ac_n "checking for __pthread_mutex_init in -lpthread""... $ac_c" 1>&6
echo "configure:1040: checking for __pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'__pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lpthread  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1048 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char __pthread_mutex_init();

int main() {
__pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1059: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
1070
1071
1072
1073
1074
1075
1076
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
	fi

	if test "$tcl_ok" = "yes"; then
	    # The space is needed
	    THREADS_LIBS=" -lpthread"
	else
	    echo $ac_n "checking for pthread_mutex_init in -lpthreads""... $ac_c" 1>&6
echo "configure:1078: checking for pthread_mutex_init in -lpthreads" >&5
ac_lib_var=`echo pthreads'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lpthreads  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1086 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1097: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
	fi

	if test "$tcl_ok" = "yes"; then
	    # The space is needed
	    THREADS_LIBS=" -lpthread"
	else
	    echo $ac_n "checking for pthread_mutex_init in -lpthreads""... $ac_c" 1>&6
echo "configure:1087: checking for pthread_mutex_init in -lpthreads" >&5
ac_lib_var=`echo pthreads'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lpthreads  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1095 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1106: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
1115
1116
1117
1118
1119
1120
1121
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
fi

	    if test "$tcl_ok" = "yes"; then
		# The space is needed
		THREADS_LIBS=" -lpthreads"
	    else
		echo $ac_n "checking for pthread_mutex_init in -lc""... $ac_c" 1>&6
echo "configure:1123: checking for pthread_mutex_init in -lc" >&5
ac_lib_var=`echo c'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lc  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1131 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1142: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
fi

	    if test "$tcl_ok" = "yes"; then
		# The space is needed
		THREADS_LIBS=" -lpthreads"
	    else
		echo $ac_n "checking for pthread_mutex_init in -lc""... $ac_c" 1>&6
echo "configure:1132: checking for pthread_mutex_init in -lc" >&5
ac_lib_var=`echo c'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lc  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1140 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1151: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
1157
1158
1159
1160
1161
1162
1163
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
else
  echo "$ac_t""no" 1>&6
tcl_ok=no
fi

	    	if test "$tcl_ok" = "no"; then
		    echo $ac_n "checking for pthread_mutex_init in -lc_r""... $ac_c" 1>&6
echo "configure:1165: checking for pthread_mutex_init in -lc_r" >&5
ac_lib_var=`echo c_r'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lc_r  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1173 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1184: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
else
  echo "$ac_t""no" 1>&6
tcl_ok=no
fi

	    	if test "$tcl_ok" = "no"; then
		    echo $ac_n "checking for pthread_mutex_init in -lc_r""... $ac_c" 1>&6
echo "configure:1174: checking for pthread_mutex_init in -lc_r" >&5
ac_lib_var=`echo c_r'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lc_r  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1182 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char pthread_mutex_init();

int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1193: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233

	# Does the pthread-implementation provide
	# 'pthread_attr_setstacksize' ?

	for ac_func in pthread_attr_setstacksize
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1222: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1227 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242

	# Does the pthread-implementation provide
	# 'pthread_attr_setstacksize' ?

	for ac_func in pthread_attr_setstacksize
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1231: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1236 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1250: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"







|







1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1259: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
  echo "$ac_t""no" 1>&6
fi
done

	for ac_func in readdir_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1277: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1282 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
  echo "$ac_t""no" 1>&6
fi
done

	for ac_func in readdir_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1286: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1291 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1305: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"







|







1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1314: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"
1336
1337
1338
1339
1340
1341
1342
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
# If we're using GCC, see if the compiler understands -pipe.  If so, use it.
# It makes compiling go faster.  (This is only a performance feature.)
#------------------------------------------------------------------------

if test -z "$no_pipe"; then
if test -n "$GCC"; then
  echo $ac_n "checking if the compiler understands -pipe""... $ac_c" 1>&6
echo "configure:1344: checking if the compiler understands -pipe" >&5
  OLDCC="$CC"  
  CC="$CC -pipe"
  cat > conftest.$ac_ext <<EOF
#line 1348 "configure"
#include "confdefs.h"

int main() {

; return 0; }
EOF
if { (eval echo configure:1355: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  echo "$ac_t""yes" 1>&6
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CC="$OLDCC"
    echo "$ac_t""no" 1>&6
fi
rm -f conftest*
fi  
fi

#--------------------------------------------------------------------
#	Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------


    echo $ac_n "checking for required early compiler flags""... $ac_c" 1>&6
echo "configure:1375: checking for required early compiler flags" >&5
    tcl_flags=""
    
    if eval "test \"`echo '$''{'tcl_cv_flag__isoc99_source'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1382 "configure"
#include "confdefs.h"
#include <stdlib.h>
int main() {
char *p = (char *)strtoll; char *q = (char *)strtoull;
; return 0; }
EOF
if { (eval echo configure:1389: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__isoc99_source=no
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  cat > conftest.$ac_ext <<EOF
#line 1397 "configure"
#include "confdefs.h"
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int main() {
char *p = (char *)strtoll; char *q = (char *)strtoull;
; return 0; }
EOF
if { (eval echo configure:1405: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__isoc99_source=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_flag__isoc99_source=no







|



|






|



















|






|






|







|







|







1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
# If we're using GCC, see if the compiler understands -pipe.  If so, use it.
# It makes compiling go faster.  (This is only a performance feature.)
#------------------------------------------------------------------------

if test -z "$no_pipe"; then
if test -n "$GCC"; then
  echo $ac_n "checking if the compiler understands -pipe""... $ac_c" 1>&6
echo "configure:1353: checking if the compiler understands -pipe" >&5
  OLDCC="$CC"  
  CC="$CC -pipe"
  cat > conftest.$ac_ext <<EOF
#line 1357 "configure"
#include "confdefs.h"

int main() {

; return 0; }
EOF
if { (eval echo configure:1364: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  echo "$ac_t""yes" 1>&6
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CC="$OLDCC"
    echo "$ac_t""no" 1>&6
fi
rm -f conftest*
fi  
fi

#--------------------------------------------------------------------
#	Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------


    echo $ac_n "checking for required early compiler flags""... $ac_c" 1>&6
echo "configure:1384: checking for required early compiler flags" >&5
    tcl_flags=""
    
    if eval "test \"`echo '$''{'tcl_cv_flag__isoc99_source'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1391 "configure"
#include "confdefs.h"
#include <stdlib.h>
int main() {
char *p = (char *)strtoll; char *q = (char *)strtoull;
; return 0; }
EOF
if { (eval echo configure:1398: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__isoc99_source=no
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  cat > conftest.$ac_ext <<EOF
#line 1406 "configure"
#include "confdefs.h"
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int main() {
char *p = (char *)strtoll; char *q = (char *)strtoull;
; return 0; }
EOF
if { (eval echo configure:1414: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__isoc99_source=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_flag__isoc99_source=no
1423
1424
1425
1426
1427
1428
1429
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
	tcl_flags="$tcl_flags _ISOC99_SOURCE"
    fi
    
    if eval "test \"`echo '$''{'tcl_cv_flag__largefile64_source'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1431 "configure"
#include "confdefs.h"
#include <sys/stat.h>
int main() {
struct stat64 buf; int i = stat64("/", &buf);
; return 0; }
EOF
if { (eval echo configure:1438: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__largefile64_source=no
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  cat > conftest.$ac_ext <<EOF
#line 1446 "configure"
#include "confdefs.h"
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int main() {
struct stat64 buf; int i = stat64("/", &buf);
; return 0; }
EOF
if { (eval echo configure:1454: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__largefile64_source=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_flag__largefile64_source=no







|






|







|







|







1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
	tcl_flags="$tcl_flags _ISOC99_SOURCE"
    fi
    
    if eval "test \"`echo '$''{'tcl_cv_flag__largefile64_source'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1440 "configure"
#include "confdefs.h"
#include <sys/stat.h>
int main() {
struct stat64 buf; int i = stat64("/", &buf);
; return 0; }
EOF
if { (eval echo configure:1447: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__largefile64_source=no
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  cat > conftest.$ac_ext <<EOF
#line 1455 "configure"
#include "confdefs.h"
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int main() {
struct stat64 buf; int i = stat64("/", &buf);
; return 0; }
EOF
if { (eval echo configure:1463: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_flag__largefile64_source=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_flag__largefile64_source=no
1475
1476
1477
1478
1479
1480
1481
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
	echo "$ac_t""none" 1>&6
    else
	echo "$ac_t""${tcl_flags}" 1>&6
    fi


    echo $ac_n "checking for 64-bit integer type""... $ac_c" 1>&6
echo "configure:1483: checking for 64-bit integer type" >&5
    if eval "test \"`echo '$''{'tcl_cv_type_64bit'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	cat > conftest.$ac_ext <<EOF
#line 1489 "configure"
#include "confdefs.h"

int main() {
__int64 value = (__int64) 0;
; return 0; }
EOF
if { (eval echo configure:1496: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_type_64bit=__int64
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_type_64bit=none
           if test "$cross_compiling" = yes; then
    { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
  cat > conftest.$ac_ext <<EOF
#line 1508 "configure"
#include "confdefs.h"
#include <unistd.h>
		int main() {exit(!(sizeof(long long) > sizeof(long)));}
		
EOF
if { (eval echo configure:1514: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_type_64bit="long long"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
fi
rm -fr conftest*







|





|






|











|





|







1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
	echo "$ac_t""none" 1>&6
    else
	echo "$ac_t""${tcl_flags}" 1>&6
    fi


    echo $ac_n "checking for 64-bit integer type""... $ac_c" 1>&6
echo "configure:1492: checking for 64-bit integer type" >&5
    if eval "test \"`echo '$''{'tcl_cv_type_64bit'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	cat > conftest.$ac_ext <<EOF
#line 1498 "configure"
#include "confdefs.h"

int main() {
__int64 value = (__int64) 0;
; return 0; }
EOF
if { (eval echo configure:1505: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_type_64bit=__int64
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_type_64bit=none
           if test "$cross_compiling" = yes; then
    { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
  cat > conftest.$ac_ext <<EOF
#line 1517 "configure"
#include "confdefs.h"
#include <unistd.h>
		int main() {exit(!(sizeof(long long) > sizeof(long)));}
		
EOF
if { (eval echo configure:1523: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_type_64bit="long long"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
fi
rm -fr conftest*
1531
1532
1533
1534
1535
1536
1537
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
#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}
EOF

	echo "$ac_t""${tcl_cv_type_64bit}" 1>&6

	# Now check for auxiliary declarations
	echo $ac_n "checking for struct dirent64""... $ac_c" 1>&6
echo "configure:1539: checking for struct dirent64" >&5
	if eval "test \"`echo '$''{'tcl_cv_struct_dirent64'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    cat > conftest.$ac_ext <<EOF
#line 1545 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/dirent.h>
int main() {
struct dirent64 p;
; return 0; }
EOF
if { (eval echo configure:1553: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_struct_dirent64=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_struct_dirent64=no
fi
rm -f conftest*
fi

	if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
	    cat >> confdefs.h <<\EOF
#define HAVE_STRUCT_DIRENT64 1
EOF

	fi
	echo "$ac_t""${tcl_cv_struct_dirent64}" 1>&6

	echo $ac_n "checking for struct stat64""... $ac_c" 1>&6
echo "configure:1574: checking for struct stat64" >&5
	if eval "test \"`echo '$''{'tcl_cv_struct_stat64'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    cat > conftest.$ac_ext <<EOF
#line 1580 "configure"
#include "confdefs.h"
#include <sys/stat.h>
int main() {
struct stat64 p;

; return 0; }
EOF
if { (eval echo configure:1588: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_struct_stat64=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_struct_stat64=no
fi
rm -f conftest*
fi

	if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
	    cat >> confdefs.h <<\EOF
#define HAVE_STRUCT_STAT64 1
EOF

	fi
	echo "$ac_t""${tcl_cv_struct_stat64}" 1>&6

	echo $ac_n "checking for off64_t""... $ac_c" 1>&6
echo "configure:1609: checking for off64_t" >&5
	if eval "test \"`echo '$''{'tcl_cv_type_off64_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    cat > conftest.$ac_ext <<EOF
#line 1615 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
off64_t offset;

; return 0; }
EOF
if { (eval echo configure:1623: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_type_off64_t=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_type_off64_t=no







|





|







|




















|





|







|




















|





|







|







1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}
EOF

	echo "$ac_t""${tcl_cv_type_64bit}" 1>&6

	# Now check for auxiliary declarations
	echo $ac_n "checking for struct dirent64""... $ac_c" 1>&6
echo "configure:1548: checking for struct dirent64" >&5
	if eval "test \"`echo '$''{'tcl_cv_struct_dirent64'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    cat > conftest.$ac_ext <<EOF
#line 1554 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/dirent.h>
int main() {
struct dirent64 p;
; return 0; }
EOF
if { (eval echo configure:1562: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_struct_dirent64=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_struct_dirent64=no
fi
rm -f conftest*
fi

	if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
	    cat >> confdefs.h <<\EOF
#define HAVE_STRUCT_DIRENT64 1
EOF

	fi
	echo "$ac_t""${tcl_cv_struct_dirent64}" 1>&6

	echo $ac_n "checking for struct stat64""... $ac_c" 1>&6
echo "configure:1583: checking for struct stat64" >&5
	if eval "test \"`echo '$''{'tcl_cv_struct_stat64'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    cat > conftest.$ac_ext <<EOF
#line 1589 "configure"
#include "confdefs.h"
#include <sys/stat.h>
int main() {
struct stat64 p;

; return 0; }
EOF
if { (eval echo configure:1597: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_struct_stat64=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_struct_stat64=no
fi
rm -f conftest*
fi

	if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
	    cat >> confdefs.h <<\EOF
#define HAVE_STRUCT_STAT64 1
EOF

	fi
	echo "$ac_t""${tcl_cv_struct_stat64}" 1>&6

	echo $ac_n "checking for off64_t""... $ac_c" 1>&6
echo "configure:1618: checking for off64_t" >&5
	if eval "test \"`echo '$''{'tcl_cv_type_off64_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    cat > conftest.$ac_ext <<EOF
#line 1624 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
off64_t offset;

; return 0; }
EOF
if { (eval echo configure:1632: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_type_off64_t=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_type_off64_t=no
1642
1643
1644
1645
1646
1647
1648
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

#--------------------------------------------------------------------
#	Check endianness because we can optimize comparisons of
#	Tcl_UniChar strings to memcmp on big-endian systems.
#--------------------------------------------------------------------

echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6
echo "configure:1650: checking whether byte ordering is bigendian" >&5
if eval "test \"`echo '$''{'ac_cv_c_bigendian'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_cv_c_bigendian=unknown
# See if sys/param.h defines the BYTE_ORDER macro.
cat > conftest.$ac_ext <<EOF
#line 1657 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
int main() {

#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN
 bogus endian macros
#endif
; return 0; }
EOF
if { (eval echo configure:1668: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  # It does; now see whether it defined to BIG_ENDIAN or not.
cat > conftest.$ac_ext <<EOF
#line 1672 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
int main() {

#if BYTE_ORDER != BIG_ENDIAN
 not big endian
#endif
; return 0; }
EOF
if { (eval echo configure:1683: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_c_bigendian=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_c_bigendian=no
fi
rm -f conftest*
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
fi
rm -f conftest*
if test $ac_cv_c_bigendian = unknown; then
if test "$cross_compiling" = yes; then
    { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
  cat > conftest.$ac_ext <<EOF
#line 1703 "configure"
#include "confdefs.h"
main () {
  /* Are we little or big endian?  From Harbison&Steele.  */
  union
  {
    long l;
    char c[sizeof (long)];
  } u;
  u.l = 1;
  exit (u.c[sizeof (long) - 1] == 1);
}
EOF
if { (eval echo configure:1716: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  ac_cv_c_bigendian=no
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_c_bigendian=yes







|






|










|



|










|



















|












|







1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731

#--------------------------------------------------------------------
#	Check endianness because we can optimize comparisons of
#	Tcl_UniChar strings to memcmp on big-endian systems.
#--------------------------------------------------------------------

echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6
echo "configure:1659: checking whether byte ordering is bigendian" >&5
if eval "test \"`echo '$''{'ac_cv_c_bigendian'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_cv_c_bigendian=unknown
# See if sys/param.h defines the BYTE_ORDER macro.
cat > conftest.$ac_ext <<EOF
#line 1666 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
int main() {

#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN
 bogus endian macros
#endif
; return 0; }
EOF
if { (eval echo configure:1677: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  # It does; now see whether it defined to BIG_ENDIAN or not.
cat > conftest.$ac_ext <<EOF
#line 1681 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
int main() {

#if BYTE_ORDER != BIG_ENDIAN
 not big endian
#endif
; return 0; }
EOF
if { (eval echo configure:1692: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_c_bigendian=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_c_bigendian=no
fi
rm -f conftest*
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
fi
rm -f conftest*
if test $ac_cv_c_bigendian = unknown; then
if test "$cross_compiling" = yes; then
    { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
  cat > conftest.$ac_ext <<EOF
#line 1712 "configure"
#include "confdefs.h"
main () {
  /* Are we little or big endian?  From Harbison&Steele.  */
  union
  {
    long l;
    char c[sizeof (long)];
  } u;
  u.l = 1;
  exit (u.c[sizeof (long) - 1] == 1);
}
EOF
if { (eval echo configure:1725: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  ac_cv_c_bigendian=no
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_c_bigendian=yes
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
#	set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------

# Check if Posix compliant getcwd exists, if not we'll use getwd.
for ac_func in getcwd
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1749: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1754 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
#	set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------

# Check if Posix compliant getcwd exists, if not we'll use getwd.
for ac_func in getcwd
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1758: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1763 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1777: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"







|







1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1786: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822

# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?

for ac_func in opendir strstr
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1811: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1816 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831

# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?

for ac_func in opendir strstr
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1820: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1825 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1839: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"







|







1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1848: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
done



for ac_func in strtol strtoll strtoull tmpnam waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1869: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1874 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
done



for ac_func in strtol strtoll strtoull tmpnam waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1878: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1883 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1897: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"







|







1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:1906: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
  echo "$ac_t""no" 1>&6
LIBOBJS="$LIBOBJS ${ac_func}.${ac_objext}"
fi
done


echo $ac_n "checking for strerror""... $ac_c" 1>&6
echo "configure:1924: checking for strerror" >&5
if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1929 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strerror(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
  echo "$ac_t""no" 1>&6
LIBOBJS="$LIBOBJS ${ac_func}.${ac_objext}"
fi
done


echo $ac_n "checking for strerror""... $ac_c" 1>&6
echo "configure:1933: checking for strerror" >&5
if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1938 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strerror(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
choke me
#else
strerror();
#endif

; return 0; }
EOF
if { (eval echo configure:1952: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strerror=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strerror=no"







|







1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
choke me
#else
strerror();
#endif

; return 0; }
EOF
if { (eval echo configure:1961: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strerror=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strerror=no"
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
cat >> confdefs.h <<\EOF
#define NO_STRERROR 1
EOF

fi

echo $ac_n "checking for getwd""... $ac_c" 1>&6
echo "configure:1976: checking for getwd" >&5
if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1981 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char getwd(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
cat >> confdefs.h <<\EOF
#define NO_STRERROR 1
EOF

fi

echo $ac_n "checking for getwd""... $ac_c" 1>&6
echo "configure:1985: checking for getwd" >&5
if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1990 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char getwd(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
choke me
#else
getwd();
#endif

; return 0; }
EOF
if { (eval echo configure:2004: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_getwd=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_getwd=no"







|







2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
choke me
#else
getwd();
#endif

; return 0; }
EOF
if { (eval echo configure:2013: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_getwd=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_getwd=no"
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
cat >> confdefs.h <<\EOF
#define NO_GETWD 1
EOF

fi

echo $ac_n "checking for wait3""... $ac_c" 1>&6
echo "configure:2028: checking for wait3" >&5
if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2033 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char wait3(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
cat >> confdefs.h <<\EOF
#define NO_GETWD 1
EOF

fi

echo $ac_n "checking for wait3""... $ac_c" 1>&6
echo "configure:2037: checking for wait3" >&5
if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2042 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char wait3(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
choke me
#else
wait3();
#endif

; return 0; }
EOF
if { (eval echo configure:2056: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_wait3=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_wait3=no"







|







2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
choke me
#else
wait3();
#endif

; return 0; }
EOF
if { (eval echo configure:2065: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_wait3=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_wait3=no"
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
cat >> confdefs.h <<\EOF
#define NO_WAIT3 1
EOF

fi

echo $ac_n "checking for uname""... $ac_c" 1>&6
echo "configure:2080: checking for uname" >&5
if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2085 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char uname(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
cat >> confdefs.h <<\EOF
#define NO_WAIT3 1
EOF

fi

echo $ac_n "checking for uname""... $ac_c" 1>&6
echo "configure:2089: checking for uname" >&5
if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2094 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char uname(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
choke me
#else
uname();
#endif

; return 0; }
EOF
if { (eval echo configure:2108: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_uname=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_uname=no"







|







2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
choke me
#else
uname();
#endif

; return 0; }
EOF
if { (eval echo configure:2117: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_uname=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_uname=no"
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
cat >> confdefs.h <<\EOF
#define NO_UNAME 1
EOF

fi

echo $ac_n "checking for realpath""... $ac_c" 1>&6
echo "configure:2132: checking for realpath" >&5
if eval "test \"`echo '$''{'ac_cv_func_realpath'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2137 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char realpath(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
cat >> confdefs.h <<\EOF
#define NO_UNAME 1
EOF

fi

echo $ac_n "checking for realpath""... $ac_c" 1>&6
echo "configure:2141: checking for realpath" >&5
if eval "test \"`echo '$''{'ac_cv_func_realpath'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2146 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char realpath(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
choke me
#else
realpath();
#endif

; return 0; }
EOF
if { (eval echo configure:2160: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_realpath=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_realpath=no"







|







2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
choke me
#else
realpath();
#endif

; return 0; }
EOF
if { (eval echo configure:2169: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_realpath=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_realpath=no"
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
#	      strtod insome versions of SunOS
#	    - some versions of string.h don't declare procedures such
#	      as strstr
#--------------------------------------------------------------------


    echo $ac_n "checking dirent.h""... $ac_c" 1>&6
echo "configure:2195: checking dirent.h" >&5
    cat > conftest.$ac_ext <<EOF
#line 2197 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <dirent.h>
int main() {

#ifndef _POSIX_SOURCE
#   ifdef __Lynx__







|

|







2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
#	      strtod insome versions of SunOS
#	    - some versions of string.h don't declare procedures such
#	      as strstr
#--------------------------------------------------------------------


    echo $ac_n "checking dirent.h""... $ac_c" 1>&6
echo "configure:2204: checking dirent.h" >&5
    cat > conftest.$ac_ext <<EOF
#line 2206 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <dirent.h>
int main() {

#ifndef _POSIX_SOURCE
#   ifdef __Lynx__
2215
2216
2217
2218
2219
2220
2221
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
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);

; return 0; }
EOF
if { (eval echo configure:2223: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  tcl_ok=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=no
fi
rm -f conftest*

    if test $tcl_ok = no; then
	cat >> confdefs.h <<\EOF
#define NO_DIRENT_H 1
EOF

    fi

    echo "$ac_t""$tcl_ok" 1>&6
    ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:2244: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2249 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2254: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




















|




|




|







2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);

; return 0; }
EOF
if { (eval echo configure:2232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  tcl_ok=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=no
fi
rm -f conftest*

    if test $tcl_ok = no; then
	cat >> confdefs.h <<\EOF
#define NO_DIRENT_H 1
EOF

    fi

    echo "$ac_t""$tcl_ok" 1>&6
    ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:2253: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2258 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2263: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
#define NO_ERRNO_H 1
EOF

fi

    ac_safe=`echo "float.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for float.h""... $ac_c" 1>&6
echo "configure:2281: checking for float.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2286 "configure"
#include "confdefs.h"
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2291: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
#define NO_ERRNO_H 1
EOF

fi

    ac_safe=`echo "float.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for float.h""... $ac_c" 1>&6
echo "configure:2290: checking for float.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2295 "configure"
#include "confdefs.h"
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2300: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
#define NO_FLOAT_H 1
EOF

fi

    ac_safe=`echo "values.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for values.h""... $ac_c" 1>&6
echo "configure:2318: checking for values.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2323 "configure"
#include "confdefs.h"
#include <values.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2328: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
#define NO_FLOAT_H 1
EOF

fi

    ac_safe=`echo "values.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for values.h""... $ac_c" 1>&6
echo "configure:2327: checking for values.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2332 "configure"
#include "confdefs.h"
#include <values.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2337: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
#define NO_VALUES_H 1
EOF

fi

    ac_safe=`echo "limits.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for limits.h""... $ac_c" 1>&6
echo "configure:2355: checking for limits.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2360 "configure"
#include "confdefs.h"
#include <limits.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2365: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
#define NO_VALUES_H 1
EOF

fi

    ac_safe=`echo "limits.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for limits.h""... $ac_c" 1>&6
echo "configure:2364: checking for limits.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2369 "configure"
#include "confdefs.h"
#include <limits.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2374: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
#define NO_LIMITS_H 1
EOF

fi

    ac_safe=`echo "stdlib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6
echo "configure:2392: checking for stdlib.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2397 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2402: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
#define NO_LIMITS_H 1
EOF

fi

    ac_safe=`echo "stdlib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6
echo "configure:2401: checking for stdlib.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2406 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2411: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2417
2418
2419
2420
2421
2422
2423
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
  tcl_ok=1
else
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

    cat > conftest.$ac_ext <<EOF
#line 2425 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strtol" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    cat > conftest.$ac_ext <<EOF
#line 2439 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strtoul" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    cat > conftest.$ac_ext <<EOF
#line 2453 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strtod" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    if test $tcl_ok = 0; then
	cat >> confdefs.h <<\EOF
#define NO_STDLIB_H 1
EOF

    fi
    ac_safe=`echo "string.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for string.h""... $ac_c" 1>&6
echo "configure:2474: checking for string.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2479 "configure"
#include "confdefs.h"
#include <string.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2484: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|













|













|




















|




|




|







2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
  tcl_ok=1
else
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

    cat > conftest.$ac_ext <<EOF
#line 2434 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strtol" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    cat > conftest.$ac_ext <<EOF
#line 2448 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strtoul" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    cat > conftest.$ac_ext <<EOF
#line 2462 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strtod" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    if test $tcl_ok = 0; then
	cat >> confdefs.h <<\EOF
#define NO_STDLIB_H 1
EOF

    fi
    ac_safe=`echo "string.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for string.h""... $ac_c" 1>&6
echo "configure:2483: checking for string.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2488 "configure"
#include "confdefs.h"
#include <string.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2493: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
  tcl_ok=1
else
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

    cat > conftest.$ac_ext <<EOF
#line 2507 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strstr" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    cat > conftest.$ac_ext <<EOF
#line 2521 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strerror" >/dev/null 2>&1; then
  :
else







|













|







2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
  tcl_ok=1
else
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

    cat > conftest.$ac_ext <<EOF
#line 2516 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strstr" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  tcl_ok=0
fi
rm -f conftest*

    cat > conftest.$ac_ext <<EOF
#line 2530 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "strerror" >/dev/null 2>&1; then
  :
else
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
#define NO_STRING_H 1
EOF

    fi

    ac_safe=`echo "sys/wait.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6
echo "configure:2547: checking for sys/wait.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2552 "configure"
#include "confdefs.h"
#include <sys/wait.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2557: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
#define NO_STRING_H 1
EOF

    fi

    ac_safe=`echo "sys/wait.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6
echo "configure:2556: checking for sys/wait.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2561 "configure"
#include "confdefs.h"
#include <sys/wait.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2566: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
#define NO_SYS_WAIT_H 1
EOF

fi

    ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
echo "configure:2584: checking for dlfcn.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2589 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2594: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
#define NO_SYS_WAIT_H 1
EOF

fi

    ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
echo "configure:2593: checking for dlfcn.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2598 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2603: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642

    # OS/390 lacks sys/param.h (and doesn't need it, by chance).

    for ac_hdr in unistd.h sys/param.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:2626: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2631 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2636: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651

    # OS/390 lacks sys/param.h (and doesn't need it, by chance).

    for ac_hdr in unistd.h sys/param.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:2635: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2640 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
#---------------------------------------------------------------------------


    for ac_hdr in sys/modem.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:2676: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2681 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2686: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
#---------------------------------------------------------------------------


    for ac_hdr in sys/modem.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:2685: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2690 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2695: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
2705
2706
2707
2708
2709
2710
2711
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
 
else
  echo "$ac_t""no" 1>&6
fi
done

    echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6
echo "configure:2713: checking termios vs. termio vs. sgtty" >&5
    if eval "test \"`echo '$''{'tcl_cv_api_serial'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
    if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2722 "configure"
#include "confdefs.h"

#include <termios.h>

int main() {
    struct termios t;
    if (tcgetattr(0, &t) == 0) {
	cfsetospeed(&t, 0);
	t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2737: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termios
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2754 "configure"
#include "confdefs.h"

#include <termio.h>

int main() {
    struct termio t;
    if (ioctl(0, TCGETA, &t) == 0) {
	t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2768: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termio
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=none
else
  cat > conftest.$ac_ext <<EOF
#line 2786 "configure"
#include "confdefs.h"

#include <sgtty.h>

int main() {
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2801: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=sgtty
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=none
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2819 "configure"
#include "confdefs.h"

#include <termios.h>
#include <errno.h>

int main() {
    struct termios t;
    if (tcgetattr(0, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	cfsetospeed(&t, 0);
	t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2836: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termios
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2854 "configure"
#include "confdefs.h"

#include <termio.h>
#include <errno.h>

int main() {
    struct termio t;
    if (ioctl(0, TCGETA, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
    }
EOF
if { (eval echo configure:2870: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termio
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=none
else
  cat > conftest.$ac_ext <<EOF
#line 2888 "configure"
#include "confdefs.h"

#include <sgtty.h>
#include <errno.h>

int main() {
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2905: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=sgtty
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=none







|








|














|
















|













|














|


|














|






|










|
















|

















|















|

















|
















|







2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
 
else
  echo "$ac_t""no" 1>&6
fi
done

    echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6
echo "configure:2722: checking termios vs. termio vs. sgtty" >&5
    if eval "test \"`echo '$''{'tcl_cv_api_serial'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
    if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2731 "configure"
#include "confdefs.h"

#include <termios.h>

int main() {
    struct termios t;
    if (tcgetattr(0, &t) == 0) {
	cfsetospeed(&t, 0);
	t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2746: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termios
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2763 "configure"
#include "confdefs.h"

#include <termio.h>

int main() {
    struct termio t;
    if (ioctl(0, TCGETA, &t) == 0) {
	t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2777: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termio
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2795 "configure"
#include "confdefs.h"

#include <sgtty.h>

int main() {
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2810: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=sgtty
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no ; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2828 "configure"
#include "confdefs.h"

#include <termios.h>
#include <errno.h>

int main() {
    struct termios t;
    if (tcgetattr(0, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	cfsetospeed(&t, 0);
	t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2845: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termios
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=no
else
  cat > conftest.$ac_ext <<EOF
#line 2863 "configure"
#include "confdefs.h"

#include <termio.h>
#include <errno.h>

int main() {
    struct termio t;
    if (ioctl(0, TCGETA, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
    }
EOF
if { (eval echo configure:2879: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=termio
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=no
fi
rm -fr conftest*
fi

    fi
    if test $tcl_cv_api_serial = no; then
	if test "$cross_compiling" = yes; then
  tcl_cv_api_serial=none
else
  cat > conftest.$ac_ext <<EOF
#line 2897 "configure"
#include "confdefs.h"

#include <sgtty.h>
#include <errno.h>

int main() {
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}
EOF
if { (eval echo configure:2914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_api_serial=sgtty
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_api_serial=none
2940
2941
2942
2943
2944
2945
2946
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
#	systems like OSF/1 have a sys/select.h that's of no use, and
#	other systems like SCO UNIX have a sys/select.h that's
#	pernicious.  If "fd_set" isn't defined anywhere then set a
#	special flag.
#--------------------------------------------------------------------

echo $ac_n "checking for fd_set in sys/types""... $ac_c" 1>&6
echo "configure:2948: checking for fd_set in sys/types" >&5
if eval "test \"`echo '$''{'tcl_cv_type_fd_set'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2953 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
fd_set readMask, writeMask;
; return 0; }
EOF
if { (eval echo configure:2960: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_type_fd_set=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_type_fd_set=no
fi
rm -f conftest*
fi

echo "$ac_t""$tcl_cv_type_fd_set" 1>&6
tk_ok=$tcl_cv_type_fd_set
if test $tcl_cv_type_fd_set = no; then
    echo $ac_n "checking for fd_mask in sys/select""... $ac_c" 1>&6
echo "configure:2976: checking for fd_mask in sys/select" >&5
    if eval "test \"`echo '$''{'tcl_cv_grep_fd_mask'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2981 "configure"
#include "confdefs.h"
#include <sys/select.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "fd_mask" >/dev/null 2>&1; then
  rm -rf conftest*
  tcl_cv_grep_fd_mask=present







|




|






|















|




|







2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
#	systems like OSF/1 have a sys/select.h that's of no use, and
#	other systems like SCO UNIX have a sys/select.h that's
#	pernicious.  If "fd_set" isn't defined anywhere then set a
#	special flag.
#--------------------------------------------------------------------

echo $ac_n "checking for fd_set in sys/types""... $ac_c" 1>&6
echo "configure:2957: checking for fd_set in sys/types" >&5
if eval "test \"`echo '$''{'tcl_cv_type_fd_set'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2962 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
fd_set readMask, writeMask;
; return 0; }
EOF
if { (eval echo configure:2969: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_type_fd_set=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_type_fd_set=no
fi
rm -f conftest*
fi

echo "$ac_t""$tcl_cv_type_fd_set" 1>&6
tk_ok=$tcl_cv_type_fd_set
if test $tcl_cv_type_fd_set = no; then
    echo $ac_n "checking for fd_mask in sys/select""... $ac_c" 1>&6
echo "configure:2985: checking for fd_mask in sys/select" >&5
    if eval "test \"`echo '$''{'tcl_cv_grep_fd_mask'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 2990 "configure"
#include "confdefs.h"
#include <sys/select.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "fd_mask" >/dev/null 2>&1; then
  rm -rf conftest*
  tcl_cv_grep_fd_mask=present
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
fi

#------------------------------------------------------------------------------
#       Find out all about time handling differences.
#------------------------------------------------------------------------------

echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
echo "configure:3018: checking whether struct tm is in sys/time.h or time.h" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3023 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <time.h>
int main() {
struct tm *tp; tp->tm_sec;
; return 0; }
EOF
if { (eval echo configure:3031: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_struct_tm=time.h
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_struct_tm=sys/time.h







|




|







|







3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
fi

#------------------------------------------------------------------------------
#       Find out all about time handling differences.
#------------------------------------------------------------------------------

echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
echo "configure:3027: checking whether struct tm is in sys/time.h or time.h" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3032 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <time.h>
int main() {
struct tm *tp; tp->tm_sec;
; return 0; }
EOF
if { (eval echo configure:3040: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_struct_tm=time.h
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_struct_tm=sys/time.h
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
fi


    for ac_hdr in sys/time.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:3056: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3061 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:3066: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
fi


    for ac_hdr in sys/time.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:3065: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3070 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:3075: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
3085
3086
3087
3088
3089
3090
3091
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
 
else
  echo "$ac_t""no" 1>&6
fi
done

    echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
echo "configure:3093: checking whether time.h and sys/time.h may both be included" >&5
if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3098 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
#include <time.h>
int main() {
struct tm *tp;
; return 0; }
EOF
if { (eval echo configure:3107: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_header_time=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_header_time=no
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_header_time" 1>&6
if test $ac_cv_header_time = yes; then
  cat >> confdefs.h <<\EOF
#define TIME_WITH_SYS_TIME 1
EOF

fi

    echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
echo "configure:3128: checking for tm_zone in struct tm" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3133 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_cv_struct_tm>
int main() {
struct tm tm; tm.tm_zone;
; return 0; }
EOF
if { (eval echo configure:3141: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_struct_tm_zone=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_struct_tm_zone=no
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_struct_tm_zone" 1>&6
if test "$ac_cv_struct_tm_zone" = yes; then
  cat >> confdefs.h <<\EOF
#define HAVE_TM_ZONE 1
EOF

else
  echo $ac_n "checking for tzname""... $ac_c" 1>&6
echo "configure:3161: checking for tzname" >&5
if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3166 "configure"
#include "confdefs.h"
#include <time.h>
#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
#endif
int main() {
atoi(*tzname);
; return 0; }
EOF
if { (eval echo configure:3176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  ac_cv_var_tzname=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_var_tzname=no







|




|








|




















|




|







|



















|




|









|







3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
 
else
  echo "$ac_t""no" 1>&6
fi
done

    echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
echo "configure:3102: checking whether time.h and sys/time.h may both be included" >&5
if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3107 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
#include <time.h>
int main() {
struct tm *tp;
; return 0; }
EOF
if { (eval echo configure:3116: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_header_time=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_header_time=no
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_header_time" 1>&6
if test $ac_cv_header_time = yes; then
  cat >> confdefs.h <<\EOF
#define TIME_WITH_SYS_TIME 1
EOF

fi

    echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
echo "configure:3137: checking for tm_zone in struct tm" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3142 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_cv_struct_tm>
int main() {
struct tm tm; tm.tm_zone;
; return 0; }
EOF
if { (eval echo configure:3150: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_struct_tm_zone=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_struct_tm_zone=no
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_struct_tm_zone" 1>&6
if test "$ac_cv_struct_tm_zone" = yes; then
  cat >> confdefs.h <<\EOF
#define HAVE_TM_ZONE 1
EOF

else
  echo $ac_n "checking for tzname""... $ac_c" 1>&6
echo "configure:3170: checking for tzname" >&5
if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3175 "configure"
#include "confdefs.h"
#include <time.h>
#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
#endif
int main() {
atoi(*tzname);
; return 0; }
EOF
if { (eval echo configure:3185: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  ac_cv_var_tzname=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_var_tzname=no
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
  fi
fi


    for ac_func in gmtime_r localtime_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:3201: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3206 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
  fi
fi


    for ac_func in gmtime_r localtime_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:3210: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3215 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char $ac_func(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:3229: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"







|







3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
choke me
#else
$ac_func();
#endif

; return 0; }
EOF
if { (eval echo configure:3238: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_$ac_func=no"
3247
3248
3249
3250
3251
3252
3253
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
else
  echo "$ac_t""no" 1>&6
fi
done


    echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
echo "configure:3255: checking tm_tzadj in struct tm" >&5
    if eval "test \"`echo '$''{'tcl_cv_member_tm_tzadj'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3260 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
struct tm tm; tm.tm_tzadj;
; return 0; }
EOF
if { (eval echo configure:3267: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_member_tm_tzadj=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_member_tm_tzadj=no
fi
rm -f conftest*
fi

    echo "$ac_t""$tcl_cv_member_tm_tzadj" 1>&6
    if test $tcl_cv_member_tm_tzadj = yes ; then
	cat >> confdefs.h <<\EOF
#define HAVE_TM_TZADJ 1
EOF

    fi

    echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
echo "configure:3288: checking tm_gmtoff in struct tm" >&5
    if eval "test \"`echo '$''{'tcl_cv_member_tm_gmtoff'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3293 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
struct tm tm; tm.tm_gmtoff;
; return 0; }
EOF
if { (eval echo configure:3300: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_member_tm_gmtoff=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_member_tm_gmtoff=no







|




|






|




















|




|






|







3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
else
  echo "$ac_t""no" 1>&6
fi
done


    echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
echo "configure:3264: checking tm_tzadj in struct tm" >&5
    if eval "test \"`echo '$''{'tcl_cv_member_tm_tzadj'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3269 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
struct tm tm; tm.tm_tzadj;
; return 0; }
EOF
if { (eval echo configure:3276: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_member_tm_tzadj=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_member_tm_tzadj=no
fi
rm -f conftest*
fi

    echo "$ac_t""$tcl_cv_member_tm_tzadj" 1>&6
    if test $tcl_cv_member_tm_tzadj = yes ; then
	cat >> confdefs.h <<\EOF
#define HAVE_TM_TZADJ 1
EOF

    fi

    echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
echo "configure:3297: checking tm_gmtoff in struct tm" >&5
    if eval "test \"`echo '$''{'tcl_cv_member_tm_gmtoff'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3302 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
struct tm tm; tm.tm_gmtoff;
; return 0; }
EOF
if { (eval echo configure:3309: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_member_tm_gmtoff=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_member_tm_gmtoff=no
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
    fi

    #
    # Its important to include time.h in this check, as some systems
    # (like convex) have timezone functions, etc.
    #
    echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
echo "configure:3325: checking long timezone variable" >&5
    if eval "test \"`echo '$''{'tcl_cv_var_timezone'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3330 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
extern long timezone;
	    timezone += 1;
	    exit (0);
; return 0; }
EOF
if { (eval echo configure:3339: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_timezone_long=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_timezone_long=no







|




|








|







3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
    fi

    #
    # Its important to include time.h in this check, as some systems
    # (like convex) have timezone functions, etc.
    #
    echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
echo "configure:3334: checking long timezone variable" >&5
    if eval "test \"`echo '$''{'tcl_cv_var_timezone'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3339 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
extern long timezone;
	    timezone += 1;
	    exit (0);
; return 0; }
EOF
if { (eval echo configure:3348: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_timezone_long=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_timezone_long=no
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
EOF

    else
	#
	# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
	#
	echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
echo "configure:3362: checking time_t timezone variable" >&5
	if eval "test \"`echo '$''{'tcl_cv_timezone_time'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3367 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
extern time_t timezone;
		timezone += 1;
		exit (0);
; return 0; }
EOF
if { (eval echo configure:3376: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_timezone_time=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_timezone_time=no







|




|








|







3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
EOF

    else
	#
	# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
	#
	echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
echo "configure:3371: checking time_t timezone variable" >&5
	if eval "test \"`echo '$''{'tcl_cv_timezone_time'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3376 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
extern time_t timezone;
		timezone += 1;
		exit (0);
; return 0; }
EOF
if { (eval echo configure:3385: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_timezone_time=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_timezone_time=no
3395
3396
3397
3398
3399
3400
3401
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


#--------------------------------------------------------------------
#	Some systems (e.g., IRIX 4.0.5) lack the st_blksize field
#	in struct stat.  But we might be able to use fstatfs instead.
#--------------------------------------------------------------------
echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
echo "configure:3403: checking for st_blksize in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3408 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
int main() {
struct stat s; s.st_blksize;
; return 0; }
EOF
if { (eval echo configure:3416: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_struct_st_blksize=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_struct_st_blksize=no
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6
if test $ac_cv_struct_st_blksize = yes; then
  cat >> confdefs.h <<\EOF
#define HAVE_ST_BLKSIZE 1
EOF

fi

echo $ac_n "checking for fstatfs""... $ac_c" 1>&6
echo "configure:3437: checking for fstatfs" >&5
if eval "test \"`echo '$''{'ac_cv_func_fstatfs'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3442 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char fstatfs(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







|




















|




|







3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457


#--------------------------------------------------------------------
#	Some systems (e.g., IRIX 4.0.5) lack the st_blksize field
#	in struct stat.  But we might be able to use fstatfs instead.
#--------------------------------------------------------------------
echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
echo "configure:3412: checking for st_blksize in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3417 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
int main() {
struct stat s; s.st_blksize;
; return 0; }
EOF
if { (eval echo configure:3425: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_struct_st_blksize=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_struct_st_blksize=no
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6
if test $ac_cv_struct_st_blksize = yes; then
  cat >> confdefs.h <<\EOF
#define HAVE_ST_BLKSIZE 1
EOF

fi

echo $ac_n "checking for fstatfs""... $ac_c" 1>&6
echo "configure:3446: checking for fstatfs" >&5
if eval "test \"`echo '$''{'ac_cv_func_fstatfs'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3451 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char fstatfs(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
choke me
#else
fstatfs();
#endif

; return 0; }
EOF
if { (eval echo configure:3465: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_fstatfs=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_fstatfs=no"







|







3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
choke me
#else
fstatfs();
#endif

; return 0; }
EOF
if { (eval echo configure:3474: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_fstatfs=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_fstatfs=no"
3486
3487
3488
3489
3490
3491
3492
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


#--------------------------------------------------------------------
#       Some system have no memcmp or it does not work with 8 bit
#       data, this checks it and add memcmp.o to LIBOBJS if needed
#--------------------------------------------------------------------
echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6
echo "configure:3494: checking for 8-bit clean memcmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_memcmp_clean'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$cross_compiling" = yes; then
  ac_cv_func_memcmp_clean=no
else
  cat > conftest.$ac_ext <<EOF
#line 3502 "configure"
#include "confdefs.h"

main()
{
  char c0 = 0x40, c1 = 0x80, c2 = 0x81;
  exit(memcmp(&c0, &c2, 1) < 0 && memcmp(&c1, &c2, 1) < 0 ? 0 : 1);
}

EOF
if { (eval echo configure:3512: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  ac_cv_func_memcmp_clean=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_func_memcmp_clean=no







|







|









|







3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527


#--------------------------------------------------------------------
#       Some system have no memcmp or it does not work with 8 bit
#       data, this checks it and add memcmp.o to LIBOBJS if needed
#--------------------------------------------------------------------
echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6
echo "configure:3503: checking for 8-bit clean memcmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_memcmp_clean'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$cross_compiling" = yes; then
  ac_cv_func_memcmp_clean=no
else
  cat > conftest.$ac_ext <<EOF
#line 3511 "configure"
#include "confdefs.h"

main()
{
  char c0 = 0x40, c1 = 0x80, c2 = 0x81;
  exit(memcmp(&c0, &c2, 1) < 0 && memcmp(&c1, &c2, 1) < 0 ? 0 : 1);
}

EOF
if { (eval echo configure:3521: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  ac_cv_func_memcmp_clean=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_func_memcmp_clean=no
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547

#--------------------------------------------------------------------
#       Some system like SunOS 4 and other BSD like systems
#       have no memmove (we assume they have bcopy instead).
#       {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo $ac_n "checking for memmove""... $ac_c" 1>&6
echo "configure:3536: checking for memmove" >&5
if eval "test \"`echo '$''{'ac_cv_func_memmove'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3541 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char memmove(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556

#--------------------------------------------------------------------
#       Some system like SunOS 4 and other BSD like systems
#       have no memmove (we assume they have bcopy instead).
#       {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo $ac_n "checking for memmove""... $ac_c" 1>&6
echo "configure:3545: checking for memmove" >&5
if eval "test \"`echo '$''{'ac_cv_func_memmove'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3550 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char memmove(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
choke me
#else
memmove();
#endif

; return 0; }
EOF
if { (eval echo configure:3564: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_memmove=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_memmove=no"







|







3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
choke me
#else
memmove();
#endif

; return 0; }
EOF
if { (eval echo configure:3573: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_memmove=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_memmove=no"
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618

#--------------------------------------------------------------------
#	On some systems strstr is broken: it returns a pointer even
#	even if the original string is empty.
#--------------------------------------------------------------------

echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6
echo "configure:3597: checking proper strstr implementation" >&5
if test "$cross_compiling" = yes; then
  tcl_ok=no
else
  cat > conftest.$ac_ext <<EOF
#line 3602 "configure"
#include "confdefs.h"

extern int strstr();
int main()
{
    exit(strstr("\0test", "test") ? 1 : 0);
}

EOF
if { (eval echo configure:3612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_ok=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=no







|




|









|







3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627

#--------------------------------------------------------------------
#	On some systems strstr is broken: it returns a pointer even
#	even if the original string is empty.
#--------------------------------------------------------------------

echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6
echo "configure:3606: checking proper strstr implementation" >&5
if test "$cross_compiling" = yes; then
  tcl_ok=no
else
  cat > conftest.$ac_ext <<EOF
#line 3611 "configure"
#include "confdefs.h"

extern int strstr();
int main()
{
    exit(strstr("\0test", "test") ? 1 : 0);
}

EOF
if { (eval echo configure:3621: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_ok=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=no
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
#--------------------------------------------------------------------
#	Check for strtoul function.  This is tricky because under some
#	versions of AIX strtoul returns an incorrect terminator
#	pointer for the string "0".
#--------------------------------------------------------------------

echo $ac_n "checking for strtoul""... $ac_c" 1>&6
echo "configure:3638: checking for strtoul" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3643 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtoul(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
#--------------------------------------------------------------------
#	Check for strtoul function.  This is tricky because under some
#	versions of AIX strtoul returns an incorrect terminator
#	pointer for the string "0".
#--------------------------------------------------------------------

echo $ac_n "checking for strtoul""... $ac_c" 1>&6
echo "configure:3647: checking for strtoul" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3652 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtoul(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
choke me
#else
strtoul();
#endif

; return 0; }
EOF
if { (eval echo configure:3666: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strtoul=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strtoul=no"







|







3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
choke me
#else
strtoul();
#endif

; return 0; }
EOF
if { (eval echo configure:3675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strtoul=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strtoul=no"
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
tcl_ok=0
fi

if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat > conftest.$ac_ext <<EOF
#line 3690 "configure"
#include "confdefs.h"

extern int strtoul();
int main()
{
    char *string = "0";
    char *term;
    int value;
    value = strtoul(string, &term, 0);
    if ((value != 0) || (term != (string+1))) {
        exit(1);
    }
    exit(0);
}
EOF
if { (eval echo configure:3706: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  :
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=0







|















|







3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
tcl_ok=0
fi

if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat > conftest.$ac_ext <<EOF
#line 3699 "configure"
#include "confdefs.h"

extern int strtoul();
int main()
{
    char *string = "0";
    char *term;
    int value;
    value = strtoul(string, &term, 0);
    if ((value != 0) || (term != (string+1))) {
        exit(1);
    }
    exit(0);
}
EOF
if { (eval echo configure:3715: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  :
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=0
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740

#--------------------------------------------------------------------
#	Check for the strtod function.  This is tricky because in some
#	versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------

echo $ac_n "checking for strtod""... $ac_c" 1>&6
echo "configure:3729: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3734 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749

#--------------------------------------------------------------------
#	Check for the strtod function.  This is tricky because in some
#	versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------

echo $ac_n "checking for strtod""... $ac_c" 1>&6
echo "configure:3738: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3743 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
choke me
#else
strtod();
#endif

; return 0; }
EOF
if { (eval echo configure:3757: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strtod=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strtod=no"







|







3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
choke me
#else
strtod();
#endif

; return 0; }
EOF
if { (eval echo configure:3766: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strtod=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strtod=no"
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
tcl_ok=0
fi

if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat > conftest.$ac_ext <<EOF
#line 3781 "configure"
#include "confdefs.h"

extern double strtod();
int main()
{
    char *string = " +69";
    char *term;
    double value;
    value = strtod(string, &term);
    if ((value != 69) || (term != (string+4))) {
	exit(1);
    }
    exit(0);
}
EOF
if { (eval echo configure:3797: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  :
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=0







|















|







3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
tcl_ok=0
fi

if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat > conftest.$ac_ext <<EOF
#line 3790 "configure"
#include "confdefs.h"

extern double strtod();
int main()
{
    char *string = " +69";
    char *term;
    double value;
    value = strtod(string, &term);
    if ((value != 69) || (term != (string+4))) {
	exit(1);
    }
    exit(0);
}
EOF
if { (eval echo configure:3806: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  :
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=0
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" that corrects the error.
#--------------------------------------------------------------------


    echo $ac_n "checking for strtod""... $ac_c" 1>&6
echo "configure:3823: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3828 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" that corrects the error.
#--------------------------------------------------------------------


    echo $ac_n "checking for strtod""... $ac_c" 1>&6
echo "configure:3832: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3837 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strtod(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
choke me
#else
strtod();
#endif

; return 0; }
EOF
if { (eval echo configure:3851: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strtod=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strtod=no"







|







3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
choke me
#else
strtod();
#endif

; return 0; }
EOF
if { (eval echo configure:3860: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strtod=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strtod=no"
3865
3866
3867
3868
3869
3870
3871
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
else
  echo "$ac_t""no" 1>&6
tcl_strtod=0
fi

    if test "$tcl_strtod" = 1; then
	echo $ac_n "checking for Solaris2.4/Tru64 strtod bugs""... $ac_c" 1>&6
echo "configure:3873: checking for Solaris2.4/Tru64 strtod bugs" >&5




	if test "$cross_compiling" = yes; then
  tcl_ok=0
else
  cat > conftest.$ac_ext <<EOF
#line 3878 "configure"
#include "confdefs.h"

	    extern double strtod();
	    int main()
	    {
		char *string = "NaN", *spaceString = " ";
		char *term;
		double value;
		value = strtod(string, &term);
		if ((term != string) && (term[-1] == 0)) {
		    exit(1);
		}




		value = strtod(spaceString, &term);
		if (term == (spaceString+1)) {
		    exit(1);
		}
		exit(0);
	    }
EOF
if { (eval echo configure:3898: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_ok=1
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_ok=0
fi
rm -fr conftest*
fi



	if test "$tcl_ok" = 1; then
	    echo "$ac_t""ok" 1>&6
	else
	    echo "$ac_t""buggy" 1>&6
	    LIBOBJS="$LIBOBJS fixstrtod.o"
	    cat >> confdefs.h <<\EOF
#define strtod fixstrtod
EOF

	fi
    fi


#--------------------------------------------------------------------
#	Check for various typedefs and provide substitutes if
#	they don't exist.
#--------------------------------------------------------------------

echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
echo "configure:3929: checking for ANSI C header files" >&5
if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3934 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:3942: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  ac_cv_header_stdc=yes
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_header_stdc=no
fi
rm -f conftest*

if test $ac_cv_header_stdc = yes; then
  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
#line 3959 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "memchr" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  ac_cv_header_stdc=no
fi
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
#line 3977 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "free" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  ac_cv_header_stdc=no
fi
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
if test "$cross_compiling" = yes; then
  :
else
  cat > conftest.$ac_ext <<EOF
#line 3998 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int main () { int i; for (i = 0; i < 256; i++)
if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2);
exit (0); }

EOF
if { (eval echo configure:4009: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  :
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_header_stdc=no







|
>
>
>
>
|
|


|


|
|
<
|
|
|
|
|
|
|
>
>
>
>
|
|
|
|
|
|

|

|




|




>
>
|


















|




|







|
















|

















|




















|










|







3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894

3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
else
  echo "$ac_t""no" 1>&6
tcl_strtod=0
fi

    if test "$tcl_strtod" = 1; then
	echo $ac_n "checking for Solaris2.4/Tru64 strtod bugs""... $ac_c" 1>&6
echo "configure:3882: checking for Solaris2.4/Tru64 strtod bugs" >&5
	if eval "test \"`echo '$''{'tcl_cv_strtod_buggy'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	    if test "$cross_compiling" = yes; then
  tcl_cv_strtod_buggy=0
else
  cat > conftest.$ac_ext <<EOF
#line 3891 "configure"
#include "confdefs.h"

		extern double strtod();
		int main() {

		    char *infString="Inf", *nanString="NaN", *spaceString=" ";
		    char *term;
		    double value;
		    value = strtod(infString, &term);
		    if ((term != infString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(nanString, &term);
		    if ((term != nanString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(spaceString, &term);
		    if (term == (spaceString+1)) {
			exit(1);
		    }
		    exit(0);
		}
EOF
if { (eval echo configure:3914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_strtod_buggy=1
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_strtod_buggy=0
fi
rm -fr conftest*
fi

fi

	if test "$tcl_cv_strtod_buggy" = 1; then
	    echo "$ac_t""ok" 1>&6
	else
	    echo "$ac_t""buggy" 1>&6
	    LIBOBJS="$LIBOBJS fixstrtod.o"
	    cat >> confdefs.h <<\EOF
#define strtod fixstrtod
EOF

	fi
    fi


#--------------------------------------------------------------------
#	Check for various typedefs and provide substitutes if
#	they don't exist.
#--------------------------------------------------------------------

echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
echo "configure:3947: checking for ANSI C header files" >&5
if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 3952 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:3960: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  ac_cv_header_stdc=yes
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_header_stdc=no
fi
rm -f conftest*

if test $ac_cv_header_stdc = yes; then
  # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
#line 3977 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "memchr" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  ac_cv_header_stdc=no
fi
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
#line 3995 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "free" >/dev/null 2>&1; then
  :
else
  rm -rf conftest*
  ac_cv_header_stdc=no
fi
rm -f conftest*

fi

if test $ac_cv_header_stdc = yes; then
  # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
if test "$cross_compiling" = yes; then
  :
else
  cat > conftest.$ac_ext <<EOF
#line 4016 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int main () { int i; for (i = 0; i < 256; i++)
if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2);
exit (0); }

EOF
if { (eval echo configure:4027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  :
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_header_stdc=no
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
  cat >> confdefs.h <<\EOF
#define STDC_HEADERS 1
EOF

fi

echo $ac_n "checking for mode_t""... $ac_c" 1>&6
echo "configure:4033: checking for mode_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4038 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF







|




|







4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
  cat >> confdefs.h <<\EOF
#define STDC_HEADERS 1
EOF

fi

echo $ac_n "checking for mode_t""... $ac_c" 1>&6
echo "configure:4051: checking for mode_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4056 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
  cat >> confdefs.h <<\EOF
#define mode_t int
EOF

fi

echo $ac_n "checking for pid_t""... $ac_c" 1>&6
echo "configure:4066: checking for pid_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4071 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF







|




|







4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
  cat >> confdefs.h <<\EOF
#define mode_t int
EOF

fi

echo $ac_n "checking for pid_t""... $ac_c" 1>&6
echo "configure:4084: checking for pid_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4089 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
  cat >> confdefs.h <<\EOF
#define pid_t int
EOF

fi

echo $ac_n "checking for size_t""... $ac_c" 1>&6
echo "configure:4099: checking for size_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4104 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF







|




|







4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
  cat >> confdefs.h <<\EOF
#define pid_t int
EOF

fi

echo $ac_n "checking for size_t""... $ac_c" 1>&6
echo "configure:4117: checking for size_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4122 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
  cat >> confdefs.h <<\EOF
#define size_t unsigned
EOF

fi

echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
echo "configure:4132: checking for uid_t in sys/types.h" >&5
if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4137 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "uid_t" >/dev/null 2>&1; then
  rm -rf conftest*
  ac_cv_type_uid_t=yes







|




|







4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
  cat >> confdefs.h <<\EOF
#define size_t unsigned
EOF

fi

echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
echo "configure:4150: checking for uid_t in sys/types.h" >&5
if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4155 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "uid_t" >/dev/null 2>&1; then
  rm -rf conftest*
  ac_cv_type_uid_t=yes
4157
4158
4159
4160
4161
4162
4163




































4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185

  cat >> confdefs.h <<\EOF
#define gid_t int
EOF

fi






































#--------------------------------------------------------------------
#	If a system doesn't have an opendir function (man, that's old!)
#	then we have to supply a different version of dirent.h which
#	is compatible with the substitute version of opendir that's
#	provided.  This version only works with V7-style directories.
#--------------------------------------------------------------------

echo $ac_n "checking for opendir""... $ac_c" 1>&6
echo "configure:4174: checking for opendir" >&5
if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4179 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char opendir(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>









|




|







4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239

  cat >> confdefs.h <<\EOF
#define gid_t int
EOF

fi


echo $ac_n "checking for socklen_t""... $ac_c" 1>&6
echo "configure:4185: checking for socklen_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_socklen_t'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4190 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/socket.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "(^|[^a-zA-Z_0-9])socklen_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then
  rm -rf conftest*
  ac_cv_type_socklen_t=yes
else
  rm -rf conftest*
  ac_cv_type_socklen_t=no
fi
rm -f conftest*

echo "$ac_t""$ac_cv_type_socklen_t" 1>&6
if test $ac_cv_type_socklen_t = no; then
  cat >> confdefs.h <<\EOF
#define socklen_t unsigned
EOF

fi

fi


#--------------------------------------------------------------------
#	If a system doesn't have an opendir function (man, that's old!)
#	then we have to supply a different version of dirent.h which
#	is compatible with the substitute version of opendir that's
#	provided.  This version only works with V7-style directories.
#--------------------------------------------------------------------

echo $ac_n "checking for opendir""... $ac_c" 1>&6
echo "configure:4228: checking for opendir" >&5
if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4233 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char opendir(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
choke me
#else
opendir();
#endif

; return 0; }
EOF
if { (eval echo configure:4202: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_opendir=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_opendir=no"







|







4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
choke me
#else
opendir();
#endif

; return 0; }
EOF
if { (eval echo configure:4256: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_opendir=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_opendir=no"
4227
4228
4229
4230
4231
4232
4233
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
#	"union wait" correctly.  It's needed because of weirdness in
#	HP-UX where "union wait" is defined in both the BSD and SYS-V
#	environments.  Checking the usability of WIFEXITED seems to do
#	the trick.
#--------------------------------------------------------------------

echo $ac_n "checking union wait""... $ac_c" 1>&6
echo "configure:4235: checking union wait" >&5
if eval "test \"`echo '$''{'tcl_cv_union_wait'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4240 "configure"
#include "confdefs.h"
#include <sys/types.h> 
#include <sys/wait.h>
int main() {

union wait x;
WIFEXITED(x);		/* Generates compiler error if WIFEXITED
			 * uses an int. */
    
; return 0; }
EOF
if { (eval echo configure:4252: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  tcl_cv_union_wait=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_union_wait=no







|




|











|







4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
#	"union wait" correctly.  It's needed because of weirdness in
#	HP-UX where "union wait" is defined in both the BSD and SYS-V
#	environments.  Checking the usability of WIFEXITED seems to do
#	the trick.
#--------------------------------------------------------------------

echo $ac_n "checking union wait""... $ac_c" 1>&6
echo "configure:4289: checking union wait" >&5
if eval "test \"`echo '$''{'tcl_cv_union_wait'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4294 "configure"
#include "confdefs.h"
#include <sys/types.h> 
#include <sys/wait.h>
int main() {

union wait x;
WIFEXITED(x);		/* Generates compiler error if WIFEXITED
			 * uses an int. */
    
; return 0; }
EOF
if { (eval echo configure:4306: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  tcl_cv_union_wait=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_union_wait=no
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
#--------------------------------------------------------------------
#	Check whether there is an strncasecmp function on this system.
#	This is a bit tricky because under SCO it's in -lsocket and
#	under Sequent Dynix it's in -linet.
#--------------------------------------------------------------------

echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6
echo "configure:4279: checking for strncasecmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4284 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strncasecmp(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
#--------------------------------------------------------------------
#	Check whether there is an strncasecmp function on this system.
#	This is a bit tricky because under SCO it's in -lsocket and
#	under Sequent Dynix it's in -linet.
#--------------------------------------------------------------------

echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6
echo "configure:4333: checking for strncasecmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4338 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char strncasecmp(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
choke me
#else
strncasecmp();
#endif

; return 0; }
EOF
if { (eval echo configure:4307: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strncasecmp=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strncasecmp=no"







|







4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
choke me
#else
strncasecmp();
#endif

; return 0; }
EOF
if { (eval echo configure:4361: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_strncasecmp=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_strncasecmp=no"
4321
4322
4323
4324
4325
4326
4327
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
else
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

if test "$tcl_ok" = 0; then
    echo $ac_n "checking for strncasecmp in -lsocket""... $ac_c" 1>&6
echo "configure:4329: checking for strncasecmp in -lsocket" >&5
ac_lib_var=`echo socket'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lsocket  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4337 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char strncasecmp();

int main() {
strncasecmp()
; return 0; }
EOF
if { (eval echo configure:4348: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
else
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

if test "$tcl_ok" = 0; then
    echo $ac_n "checking for strncasecmp in -lsocket""... $ac_c" 1>&6
echo "configure:4383: checking for strncasecmp in -lsocket" >&5
ac_lib_var=`echo socket'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lsocket  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4391 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char strncasecmp();

int main() {
strncasecmp()
; return 0; }
EOF
if { (eval echo configure:4402: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
4364
4365
4366
4367
4368
4369
4370
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
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

fi
if test "$tcl_ok" = 0; then
    echo $ac_n "checking for strncasecmp in -linet""... $ac_c" 1>&6
echo "configure:4372: checking for strncasecmp in -linet" >&5
ac_lib_var=`echo inet'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-linet  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4380 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char strncasecmp();

int main() {
strncasecmp()
; return 0; }
EOF
if { (eval echo configure:4391: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
  echo "$ac_t""no" 1>&6
tcl_ok=0
fi

fi
if test "$tcl_ok" = 0; then
    echo $ac_n "checking for strncasecmp in -linet""... $ac_c" 1>&6
echo "configure:4426: checking for strncasecmp in -linet" >&5
ac_lib_var=`echo inet'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-linet  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4434 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char strncasecmp();

int main() {
strncasecmp()
; return 0; }
EOF
if { (eval echo configure:4445: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
#	   but they have a BSDgettimeofday function that can be used instead.
#	3. See if gettimeofday is declared in the <sys/time.h> header file.
#	   if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can
#	   declare it.
#--------------------------------------------------------------------

echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6
echo "configure:4429: checking for BSDgettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4434 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char BSDgettimeofday(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
#	   but they have a BSDgettimeofday function that can be used instead.
#	3. See if gettimeofday is declared in the <sys/time.h> header file.
#	   if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can
#	   declare it.
#--------------------------------------------------------------------

echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6
echo "configure:4483: checking for BSDgettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4488 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char BSDgettimeofday(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
choke me
#else
BSDgettimeofday();
#endif

; return 0; }
EOF
if { (eval echo configure:4457: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_BSDgettimeofday=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_BSDgettimeofday=no"







|







4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
choke me
#else
BSDgettimeofday();
#endif

; return 0; }
EOF
if { (eval echo configure:4511: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_BSDgettimeofday=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_BSDgettimeofday=no"
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
#define HAVE_BSDGETTIMEOFDAY 1
EOF

else
  echo "$ac_t""no" 1>&6

    echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
echo "configure:4479: checking for gettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4484 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gettimeofday(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
#define HAVE_BSDGETTIMEOFDAY 1
EOF

else
  echo "$ac_t""no" 1>&6

    echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
echo "configure:4533: checking for gettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4538 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gettimeofday(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
choke me
#else
gettimeofday();
#endif

; return 0; }
EOF
if { (eval echo configure:4507: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_gettimeofday=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_gettimeofday=no"







|







4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
choke me
#else
gettimeofday();
#endif

; return 0; }
EOF
if { (eval echo configure:4561: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_gettimeofday=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_gettimeofday=no"
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545

fi


fi

echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
echo "configure:4534: checking for gettimeofday declaration" >&5
if eval "test \"`echo '$''{'tcl_cv_grep_gettimeofday'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4539 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "gettimeofday" >/dev/null 2>&1; then
  rm -rf conftest*
  tcl_cv_grep_gettimeofday=present







|




|







4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599

fi


fi

echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
echo "configure:4588: checking for gettimeofday declaration" >&5
if eval "test \"`echo '$''{'tcl_cv_grep_gettimeofday'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4593 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
  egrep "gettimeofday" >/dev/null 2>&1; then
  rm -rf conftest*
  tcl_cv_grep_gettimeofday=present
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
#--------------------------------------------------------------------
#	The following code checks to see whether it is possible to get
#	signed chars on this platform.  This is needed in order to
#	properly generate sign-extended ints from character values.
#--------------------------------------------------------------------

echo $ac_n "checking whether char is unsigned""... $ac_c" 1>&6
echo "configure:4570: checking whether char is unsigned" >&5
if eval "test \"`echo '$''{'ac_cv_c_char_unsigned'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$GCC" = yes; then
  # GCC predefines this symbol on systems where it applies.
cat > conftest.$ac_ext <<EOF
#line 4577 "configure"
#include "confdefs.h"
#ifdef __CHAR_UNSIGNED__
  yes
#endif

EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |







|






|







4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
#--------------------------------------------------------------------
#	The following code checks to see whether it is possible to get
#	signed chars on this platform.  This is needed in order to
#	properly generate sign-extended ints from character values.
#--------------------------------------------------------------------

echo $ac_n "checking whether char is unsigned""... $ac_c" 1>&6
echo "configure:4624: checking whether char is unsigned" >&5
if eval "test \"`echo '$''{'ac_cv_c_char_unsigned'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$GCC" = yes; then
  # GCC predefines this symbol on systems where it applies.
cat > conftest.$ac_ext <<EOF
#line 4631 "configure"
#include "confdefs.h"
#ifdef __CHAR_UNSIGNED__
  yes
#endif

EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
rm -f conftest*

else
if test "$cross_compiling" = yes; then
    { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
  cat > conftest.$ac_ext <<EOF
#line 4599 "configure"
#include "confdefs.h"
/* volatile prevents gcc2 from optimizing the test away on sparcs.  */
#if !defined(__STDC__) || __STDC__ != 1
#define volatile
#endif
main() {
  volatile char c = 255; exit(c < 0);
}
EOF
if { (eval echo configure:4609: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  ac_cv_c_char_unsigned=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_c_char_unsigned=no







|









|







4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
rm -f conftest*

else
if test "$cross_compiling" = yes; then
    { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
  cat > conftest.$ac_ext <<EOF
#line 4653 "configure"
#include "confdefs.h"
/* volatile prevents gcc2 from optimizing the test away on sparcs.  */
#if !defined(__STDC__) || __STDC__ != 1
#define volatile
#endif
main() {
  volatile char c = 255; exit(c < 0);
}
EOF
if { (eval echo configure:4663: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  ac_cv_c_char_unsigned=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  ac_cv_c_char_unsigned=no
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
  cat >> confdefs.h <<\EOF
#define __CHAR_UNSIGNED__ 1
EOF

fi

echo $ac_n "checking signed char declarations""... $ac_c" 1>&6
echo "configure:4633: checking signed char declarations" >&5
if eval "test \"`echo '$''{'tcl_cv_char_signed'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4638 "configure"
#include "confdefs.h"

int main() {

	signed char *p;
	p = 0;
	
; return 0; }
EOF
if { (eval echo configure:4648: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_char_signed=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_char_signed=no







|




|









|







4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
  cat >> confdefs.h <<\EOF
#define __CHAR_UNSIGNED__ 1
EOF

fi

echo $ac_n "checking signed char declarations""... $ac_c" 1>&6
echo "configure:4687: checking signed char declarations" >&5
if eval "test \"`echo '$''{'tcl_cv_char_signed'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4692 "configure"
#include "confdefs.h"

int main() {

	signed char *p;
	p = 0;
	
; return 0; }
EOF
if { (eval echo configure:4702: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_cv_char_signed=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_cv_char_signed=no
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703


    HAVE_LANGINFO=0
    if test "$langinfo_ok" = "yes"; then
	if test "$langinfo_ok" = "yes"; then
	    ac_safe=`echo "langinfo.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for langinfo.h""... $ac_c" 1>&6
echo "configure:4687: checking for langinfo.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4692 "configure"
#include "confdefs.h"
#include <langinfo.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:4697: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757


    HAVE_LANGINFO=0
    if test "$langinfo_ok" = "yes"; then
	if test "$langinfo_ok" = "yes"; then
	    ac_safe=`echo "langinfo.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for langinfo.h""... $ac_c" 1>&6
echo "configure:4741: checking for langinfo.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4746 "configure"
#include "confdefs.h"
#include <langinfo.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:4751: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
  echo "$ac_t""no" 1>&6
langinfo_ok=no
fi

	fi
    fi
    echo $ac_n "checking whether to use nl_langinfo""... $ac_c" 1>&6
echo "configure:4722: checking whether to use nl_langinfo" >&5
    if test "$langinfo_ok" = "yes"; then
	cat > conftest.$ac_ext <<EOF
#line 4725 "configure"
#include "confdefs.h"
#include <langinfo.h>
int main() {
nl_langinfo(CODESET);
; return 0; }
EOF
if { (eval echo configure:4732: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  langinfo_ok=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  langinfo_ok=no







|


|






|







4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
  echo "$ac_t""no" 1>&6
langinfo_ok=no
fi

	fi
    fi
    echo $ac_n "checking whether to use nl_langinfo""... $ac_c" 1>&6
echo "configure:4776: checking whether to use nl_langinfo" >&5
    if test "$langinfo_ok" = "yes"; then
	cat > conftest.$ac_ext <<EOF
#line 4779 "configure"
#include "confdefs.h"
#include <langinfo.h>
int main() {
nl_langinfo(CODESET);
; return 0; }
EOF
if { (eval echo configure:4786: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  langinfo_ok=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  langinfo_ok=no
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
    # On a few very rare systems, all of the libm.a stuff is
    # already in libc.a.  Set compiler flags accordingly.
    # Also, Linux requires the "ieee" library for math to work
    # right (and it must appear before "-lm").
    #--------------------------------------------------------------------

    echo $ac_n "checking for sin""... $ac_c" 1>&6
echo "configure:4768: checking for sin" >&5
if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4773 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char sin(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
    # On a few very rare systems, all of the libm.a stuff is
    # already in libc.a.  Set compiler flags accordingly.
    # Also, Linux requires the "ieee" library for math to work
    # right (and it must appear before "-lm").
    #--------------------------------------------------------------------

    echo $ac_n "checking for sin""... $ac_c" 1>&6
echo "configure:4822: checking for sin" >&5
if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4827 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char sin(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
4788
4789
4790
4791
4792
4793
4794
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
choke me
#else
sin();
#endif

; return 0; }
EOF
if { (eval echo configure:4796: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_sin=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_sin=no"
fi
rm -f conftest*
fi

if eval "test \"`echo '$ac_cv_func_'sin`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  MATH_LIBS=""
else
  echo "$ac_t""no" 1>&6
MATH_LIBS="-lm"
fi

    echo $ac_n "checking for main in -lieee""... $ac_c" 1>&6
echo "configure:4817: checking for main in -lieee" >&5
ac_lib_var=`echo ieee'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lieee  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4825 "configure"
#include "confdefs.h"

int main() {
main()
; return 0; }
EOF
if { (eval echo configure:4832: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|




















|







|






|







4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
choke me
#else
sin();
#endif

; return 0; }
EOF
if { (eval echo configure:4850: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_sin=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_sin=no"
fi
rm -f conftest*
fi

if eval "test \"`echo '$ac_cv_func_'sin`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  MATH_LIBS=""
else
  echo "$ac_t""no" 1>&6
MATH_LIBS="-lm"
fi

    echo $ac_n "checking for main in -lieee""... $ac_c" 1>&6
echo "configure:4871: checking for main in -lieee" >&5
ac_lib_var=`echo ieee'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lieee  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4879 "configure"
#include "confdefs.h"

int main() {
main()
; return 0; }
EOF
if { (eval echo configure:4886: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880

    #--------------------------------------------------------------------
    # Interactive UNIX requires -linet instead of -lsocket, plus it
    # needs net/errno.h to define the socket-related error codes.
    #--------------------------------------------------------------------

    echo $ac_n "checking for main in -linet""... $ac_c" 1>&6
echo "configure:4859: checking for main in -linet" >&5
ac_lib_var=`echo inet'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-linet  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4867 "configure"
#include "confdefs.h"

int main() {
main()
; return 0; }
EOF
if { (eval echo configure:4874: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|






|







4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934

    #--------------------------------------------------------------------
    # Interactive UNIX requires -linet instead of -lsocket, plus it
    # needs net/errno.h to define the socket-related error codes.
    #--------------------------------------------------------------------

    echo $ac_n "checking for main in -linet""... $ac_c" 1>&6
echo "configure:4913: checking for main in -linet" >&5
ac_lib_var=`echo inet'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-linet  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4921 "configure"
#include "confdefs.h"

int main() {
main()
; return 0; }
EOF
if { (eval echo configure:4928: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
  LIBS="$LIBS -linet"
else
  echo "$ac_t""no" 1>&6
fi

    ac_safe=`echo "net/errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6
echo "configure:4896: checking for net/errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4901 "configure"
#include "confdefs.h"
#include <net/errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:4906: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
  LIBS="$LIBS -linet"
else
  echo "$ac_t""no" 1>&6
fi

    ac_safe=`echo "net/errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6
echo "configure:4950: checking for net/errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4955 "configure"
#include "confdefs.h"
#include <net/errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:4960: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
    #	4. On some SVR4 systems, can't use -lsocket without -lnsl too.
    #	   To get around this problem, check for both libraries together
    #	   if -lsocket doesn't work by itself.
    #--------------------------------------------------------------------

    tcl_checkBoth=0
    echo $ac_n "checking for connect""... $ac_c" 1>&6
echo "configure:4951: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 4956 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char connect(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
    #	4. On some SVR4 systems, can't use -lsocket without -lnsl too.
    #	   To get around this problem, check for both libraries together
    #	   if -lsocket doesn't work by itself.
    #--------------------------------------------------------------------

    tcl_checkBoth=0
    echo $ac_n "checking for connect""... $ac_c" 1>&6
echo "configure:5005: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5010 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char connect(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
choke me
#else
connect();
#endif

; return 0; }
EOF
if { (eval echo configure:4979: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_connect=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_connect=no"







|







5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
choke me
#else
connect();
#endif

; return 0; }
EOF
if { (eval echo configure:5033: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_connect=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_connect=no"
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
else
  echo "$ac_t""no" 1>&6
tcl_checkSocket=1
fi

    if test "$tcl_checkSocket" = 1; then
	echo $ac_n "checking for setsockopt""... $ac_c" 1>&6
echo "configure:5001: checking for setsockopt" >&5
if eval "test \"`echo '$''{'ac_cv_func_setsockopt'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5006 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char setsockopt(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
else
  echo "$ac_t""no" 1>&6
tcl_checkSocket=1
fi

    if test "$tcl_checkSocket" = 1; then
	echo $ac_n "checking for setsockopt""... $ac_c" 1>&6
echo "configure:5055: checking for setsockopt" >&5
if eval "test \"`echo '$''{'ac_cv_func_setsockopt'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5060 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char setsockopt(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
5021
5022
5023
5024
5025
5026
5027
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
choke me
#else
setsockopt();
#endif

; return 0; }
EOF
if { (eval echo configure:5029: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_setsockopt=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_setsockopt=no"
fi
rm -f conftest*
fi

if eval "test \"`echo '$ac_cv_func_'setsockopt`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  :
else
  echo "$ac_t""no" 1>&6
echo $ac_n "checking for setsockopt in -lsocket""... $ac_c" 1>&6
echo "configure:5047: checking for setsockopt in -lsocket" >&5
ac_lib_var=`echo socket'_'setsockopt | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lsocket  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5055 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char setsockopt();

int main() {
setsockopt()
; return 0; }
EOF
if { (eval echo configure:5066: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|

















|







|










|







5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
choke me
#else
setsockopt();
#endif

; return 0; }
EOF
if { (eval echo configure:5083: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_setsockopt=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_setsockopt=no"
fi
rm -f conftest*
fi

if eval "test \"`echo '$ac_cv_func_'setsockopt`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  :
else
  echo "$ac_t""no" 1>&6
echo $ac_n "checking for setsockopt in -lsocket""... $ac_c" 1>&6
echo "configure:5101: checking for setsockopt in -lsocket" >&5
ac_lib_var=`echo socket'_'setsockopt | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lsocket  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5109 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char setsockopt();

int main() {
setsockopt()
; return 0; }
EOF
if { (eval echo configure:5120: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
fi

    fi
    if test "$tcl_checkBoth" = 1; then
	tk_oldLibs=$LIBS
	LIBS="$LIBS -lsocket -lnsl"
	echo $ac_n "checking for accept""... $ac_c" 1>&6
echo "configure:5094: checking for accept" >&5
if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5099 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char accept(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
fi

    fi
    if test "$tcl_checkBoth" = 1; then
	tk_oldLibs=$LIBS
	LIBS="$LIBS -lsocket -lnsl"
	echo $ac_n "checking for accept""... $ac_c" 1>&6
echo "configure:5148: checking for accept" >&5
if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5153 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char accept(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
choke me
#else
accept();
#endif

; return 0; }
EOF
if { (eval echo configure:5122: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_accept=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_accept=no"







|







5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
choke me
#else
accept();
#endif

; return 0; }
EOF
if { (eval echo configure:5176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_accept=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_accept=no"
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
else
  echo "$ac_t""no" 1>&6
LIBS=$tk_oldLibs
fi

    fi
    echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
echo "configure:5144: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5149 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gethostbyname(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */







|




|







5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
else
  echo "$ac_t""no" 1>&6
LIBS=$tk_oldLibs
fi

    fi
    echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
echo "configure:5198: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5203 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
    which can conflict with char gethostbyname(); below.  */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
5164
5165
5166
5167
5168
5169
5170
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
choke me
#else
gethostbyname();
#endif

; return 0; }
EOF
if { (eval echo configure:5172: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_gethostbyname=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_gethostbyname=no"
fi
rm -f conftest*
fi

if eval "test \"`echo '$ac_cv_func_'gethostbyname`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  :
else
  echo "$ac_t""no" 1>&6
echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
echo "configure:5190: checking for gethostbyname in -lnsl" >&5
ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lnsl  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5198 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char gethostbyname();

int main() {
gethostbyname()
; return 0; }
EOF
if { (eval echo configure:5209: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|

















|







|










|







5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
choke me
#else
gethostbyname();
#endif

; return 0; }
EOF
if { (eval echo configure:5226: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_func_gethostbyname=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_func_gethostbyname=no"
fi
rm -f conftest*
fi

if eval "test \"`echo '$ac_cv_func_'gethostbyname`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  :
else
  echo "$ac_t""no" 1>&6
echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
echo "configure:5244: checking for gethostbyname in -lnsl" >&5
ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lnsl  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5252 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char gethostbyname();

int main() {
gethostbyname()
; return 0; }
EOF
if { (eval echo configure:5263: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
5235
5236
5237
5238
5239
5240
5241
5242
































5243
5244
5245
5246
5247
5248






























5249
5250
5251
5252
5253
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
    
    


# Add the threads support libraries

LIBS="$LIBS$THREADS_LIBS"

































#--------------------------------------------------------------------
# The statements below define a collection of compile flags.  This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------

































    # Step 0.a: Enable 64 bit support?

    echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:5255: checking if 64bit support is requested" >&5
    # Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
  enableval="$enable_64bit"
  :
else
  enableval="no"
fi


    if test "$enableval" = "yes"; then
	do64bit=yes
    else
	do64bit=no
    fi
    echo "$ac_t""$do64bit" 1>&6

    # Step 0.b: Enable Solaris 64 bit VIS support?

    echo $ac_n "checking if 64bit Sparc VIS support is requested""... $ac_c" 1>&6
echo "configure:5275: checking if 64bit Sparc VIS support is requested" >&5
    # Check whether --enable-64bit-vis or --disable-64bit-vis was given.
if test "${enable_64bit_vis+set}" = set; then
  enableval="$enable_64bit_vis"
  :
else
  enableval="no"
fi








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|



















|







5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
    
    


# Add the threads support libraries

LIBS="$LIBS$THREADS_LIBS"


    echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:5300: checking how to build libraries" >&5
    # Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
  enableval="$enable_shared"
  tcl_ok=$enableval
else
  tcl_ok=yes
fi


    if test "${enable_shared+set}" = set; then
	enableval="$enable_shared"
	tcl_ok=$enableval
    else
	tcl_ok=yes
    fi

    if test "$tcl_ok" = "yes" ; then
	echo "$ac_t""shared" 1>&6
	SHARED_BUILD=1
    else
	echo "$ac_t""static" 1>&6
	SHARED_BUILD=0
	cat >> confdefs.h <<\EOF
#define STATIC_BUILD 1
EOF

    fi


#--------------------------------------------------------------------
# The statements below define a collection of compile flags.  This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------

# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:5339: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$RANLIB"; then
  ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
  ac_dummy="$PATH"
  for ac_dir in $ac_dummy; do
    test -z "$ac_dir" && ac_dir=.
    if test -f $ac_dir/$ac_word; then
      ac_cv_prog_RANLIB="ranlib"
      break
    fi
  done
  IFS="$ac_save_ifs"
  test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
fi
fi
RANLIB="$ac_cv_prog_RANLIB"
if test -n "$RANLIB"; then
  echo "$ac_t""$RANLIB" 1>&6
else
  echo "$ac_t""no" 1>&6
fi



    # Step 0.a: Enable 64 bit support?

    echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:5371: checking if 64bit support is requested" >&5
    # Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
  enableval="$enable_64bit"
  :
else
  enableval="no"
fi


    if test "$enableval" = "yes"; then
	do64bit=yes
    else
	do64bit=no
    fi
    echo "$ac_t""$do64bit" 1>&6

    # Step 0.b: Enable Solaris 64 bit VIS support?

    echo $ac_n "checking if 64bit Sparc VIS support is requested""... $ac_c" 1>&6
echo "configure:5391: checking if 64bit Sparc VIS support is requested" >&5
    # Check whether --enable-64bit-vis or --disable-64bit-vis was given.
if test "${enable_64bit_vis+set}" = set; then
  enableval="$enable_64bit_vis"
  :
else
  enableval="no"
fi
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
    echo "$ac_t""$do64bitVIS" 1>&6

    # Step 1: set the variable "system" to hold the name and version number
    # for the system.  This can usually be done via the "uname" command, but
    # there are a few systems, like Next, where this doesn't work.

    echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6
echo "configure:5299: checking system version (for dynamic loading)" >&5
    if test -f /usr/lib/NextStep/software_version; then
	system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
    else
	system=`uname -s`-`uname -r`
	if test "$?" -ne 0 ; then
	    echo "$ac_t""unknown (can't find uname command)" 1>&6
	    system=unknown







|







5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
    echo "$ac_t""$do64bitVIS" 1>&6

    # Step 1: set the variable "system" to hold the name and version number
    # for the system.  This can usually be done via the "uname" command, but
    # there are a few systems, like Next, where this doesn't work.

    echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6
echo "configure:5415: checking system version (for dynamic loading)" >&5
    if test -f /usr/lib/NextStep/software_version; then
	system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
    else
	system=`uname -s`-`uname -r`
	if test "$?" -ne 0 ; then
	    echo "$ac_t""unknown (can't find uname command)" 1>&6
	    system=unknown
5317
5318
5319
5320
5321
5322
5323
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
	fi
    fi

    # Step 2: check for existence of -ldl library.  This is needed because
    # Linux can use either -ldl or -ldld for dynamic loading.

    echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
echo "configure:5325: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-ldl  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5333 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char dlopen();

int main() {
dlopen()
; return 0; }
EOF
if { (eval echo configure:5344: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
	fi
    fi

    # Step 2: check for existence of -ldl library.  This is needed because
    # Linux can use either -ldl or -ldld for dynamic loading.

    echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
echo "configure:5441: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-ldl  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5449 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char dlopen();

int main() {
dlopen()
; return 0; }
EOF
if { (eval echo configure:5460: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
    fi
    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
    # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:5388: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$AR"; then
  ac_cv_prog_AR="$AR" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
    fi
    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
    # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:5504: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$AR"; then
  ac_cv_prog_AR="$AR" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
5432
5433
5434
5435
5436
5437
5438

5439
5440
5441
5442
5443

5444
5445
5446
5447
5448
5449
5450

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # AIX-5 has dl* in libc.so
	    DL_LIBS=""
	    LDFLAGS=""

	    if test "$GCC" = "yes" ; then
		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    else
		LD_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
	    fi


	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
		else 
		    do64bit_ok=yes







>

|

|

>







5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # AIX-5 has dl* in libc.so
	    DL_LIBS=""
	    LDFLAGS=""

	    if test "$GCC" = "yes" ; then
	        CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    else
	        CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
		else 
		    do64bit_ok=yes
5465
5466
5467
5468
5469
5470
5471
5472

5473
5474
5475
5476
5477
5478
5479
	    SHLIB_CFLAGS=""
	    SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		LIBOBJS="$LIBOBJS tclLoadAix.o"
		DL_LIBS="-lld"







|
>







5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
	    SHLIB_CFLAGS=""
	    SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		LIBOBJS="$LIBOBJS tclLoadAix.o"
		DL_LIBS="-lld"
5488
5489
5490
5491
5492
5493
5494
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
	    # AIX does not have a timezone field in struct tm. When the AIX
	    # bsd library is used, the timezone global and the gettimeofday
	    # methods are to be avoided for timezone deduction instead, we
	    # deduce the timezone by comparing the localtime result on a
	    # known GMT value.

	    echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
echo "configure:5496: checking for gettimeofday in -lbsd" >&5
ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lbsd  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5504 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char gettimeofday();

int main() {
gettimeofday()
; return 0; }
EOF
if { (eval echo configure:5515: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|







|










|







5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
	    # AIX does not have a timezone field in struct tm. When the AIX
	    # bsd library is used, the timezone global and the gettimeofday
	    # methods are to be avoided for timezone deduction instead, we
	    # deduce the timezone by comparing the localtime result on a
	    # known GMT value.

	    echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
echo "configure:5615: checking for gettimeofday in -lbsd" >&5
ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-lbsd  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5623 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char gettimeofday();

int main() {
gettimeofday()
; return 0; }
EOF
if { (eval echo configure:5634: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
5555
5556
5557
5558
5559
5560
5561

5562
5563
5564
5565
5566
5567
5568
5569
5570
5571

5572
5573
5574
5575
5576
5577
5578
5579
5580
5581

5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
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
	    SHLIB_CFLAGS=""
	    SHLIB_LD="shlicc -r"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	BSD/OS-4.*)
	    SHLIB_CFLAGS="-export-dynamic -fPIC"
	    SHLIB_LD="cc -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-export-dynamic"

	    LD_SEARCH_FLAGS=""
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	HP-UX-*.11.*)
	    # Use updated header definitions where possible
	    cat >> confdefs.h <<\EOF
#define _XOPEN_SOURCE_EXTENDED 1
EOF


	    SHLIB_SUFFIX=".sl"
	    echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
echo "configure:5594: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-ldld  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5602 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char shl_load();

int main() {
shl_load()
; return 0; }
EOF
if { (eval echo configure:5613: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







>










>










>











|







|










|







5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
	    SHLIB_CFLAGS=""
	    SHLIB_LD="shlicc -r"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	BSD/OS-4.*)
	    SHLIB_CFLAGS="-export-dynamic -fPIC"
	    SHLIB_LD="cc -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-export-dynamic"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	HP-UX-*.11.*)
	    # Use updated header definitions where possible
	    cat >> confdefs.h <<\EOF
#define _XOPEN_SOURCE_EXTENDED 1
EOF


	    SHLIB_SUFFIX=".sl"
	    echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
echo "configure:5716: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-ldld  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5724 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char shl_load();

int main() {
shl_load()
; return 0; }
EOF
if { (eval echo configure:5735: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
5633
5634
5635
5636
5637
5638
5639
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
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS='${LIBS}'
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'

	    fi

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
		else 
		    do64bit_ok=yes
		    EXTRA_CFLAGS="+DA2.0W"
		    LDFLAGS="+DA2.0W $LDFLAGS"
		fi
	    fi
	    ;;
	HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
	    SHLIB_SUFFIX=".sl"
	    echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
echo "configure:5658: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-ldld  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5666 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char shl_load();

int main() {
shl_load()
; return 0; }
EOF
if { (eval echo configure:5677: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"







|
>
















|







|










|







5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS='${LIBS}'
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
	    fi

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
		else 
		    do64bit_ok=yes
		    EXTRA_CFLAGS="+DA2.0W"
		    LDFLAGS="+DA2.0W $LDFLAGS"
		fi
	    fi
	    ;;
	HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
	    SHLIB_SUFFIX=".sl"
	    echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
echo "configure:5781: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  ac_save_LIBS="$LIBS"
LIBS="-ldld  $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5789 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error.  */
/* We use char because int might match the return type of a gcc2
    builtin and then its argument prototype would still apply.  */
char shl_load();

int main() {
shl_load()
; return 0; }
EOF
if { (eval echo configure:5800: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=yes"
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_lib_$ac_lib_var=no"
5697
5698
5699
5700
5701
5702
5703
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
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS=""
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'

	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    EXTRA_CFLAGS=""
	    LDFLAGS=""
	    ;;
	IRIX-6.*|IRIX64-6.5*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    if test "$GCC" = "yes" ; then
		EXTRA_CFLAGS="-mabi=n32"
		LDFLAGS="-mabi=n32"
	    else
		case $system in
		    IRIX-6.3)
			# Use to build 6.2 compatible binaries on 6.3.







|
>










|
>









|
>










|
>







5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS=""
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    EXTRA_CFLAGS=""
	    LDFLAGS=""
	    ;;
	IRIX-6.*|IRIX64-6.5*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    if test "$GCC" = "yes" ; then
		EXTRA_CFLAGS="-mabi=n32"
		LDFLAGS="-mabi=n32"
	    else
		case $system in
		    IRIX-6.3)
			# Use to build 6.2 compatible binaries on 6.3.
5754
5755
5756
5757
5758
5759
5760
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
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'















	    ;;
	Linux*)
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings 
	    # when you inline the string and math operations.  Turn this off to
	    # get rid of the warnings.

	    CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    else
		ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
echo "configure:5784: checking for dld.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5789 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:5794: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  
		    SHLIB_LD="ld -shared"
		    DL_OBJS="tclLoadDld.o"
		    DL_LIBS="-ldld"
		    LDFLAGS=""

		    LD_SEARCH_FLAGS=""
else
  echo "$ac_t""no" 1>&6
fi

	    fi
	    if test "`uname -m`" = "alpha" ; then







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

















|
>



|




|




|




















>







5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'

	    # Check to enable 64-bit flags for compiler/linker

	    if test "$do64bit" = "yes" ; then
	        if test "$GCC" = "yes" ; then
	            echo "configure: warning: 64bit mode not supported by gcc" 1>&2
	        else
	            do64bit_ok=yes
	            SHLIB_LD="ld -64 -shared -rdata_shared"
	            EXTRA_CFLAGS="-64"
	            LDFLAGS="-64"
	        fi
	    fi

	    ;;
	Linux*)
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings 
	    # when you inline the string and math operations.  Turn this off to
	    # get rid of the warnings.

	    CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    else
		ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
echo "configure:5927: checking for dld.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5932 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:5937: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  
		    SHLIB_LD="ld -shared"
		    DL_OBJS="tclLoadDld.o"
		    DL_LIBS="-ldld"
		    LDFLAGS=""
		    CC_SEARCH_FLAGS=""
		    LD_SEARCH_FLAGS=""
else
  echo "$ac_t""no" 1>&6
fi

	    fi
	    if test "`uname -m`" = "alpha" ; then
5839
5840
5841
5842
5843
5844
5845

5846
5847
5848
5849
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
	    SHLIB_SUFFIX=".so"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS=""
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"

		LD_SEARCH_FLAGS=""
	    else
		ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
echo "configure:5851: checking for dld.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5856 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:5861: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  
		    SHLIB_LD="ld -shared"
		    DL_OBJS=""
		    DL_LIBS="-ldld"
		    LDFLAGS=""

		    LD_SEARCH_FLAGS=""
else
  echo "$ac_t""no" 1>&6
fi

	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi
	    ;;
	MP-RAS-02*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	MP-RAS-*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-Wl,-Bexport"

	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[1-2].*|OpenBSD-*)
	    # Not available on all versions:  check for include file.
	    ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
echo "configure:5916: checking for dlfcn.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 5921 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:5926: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







>




|




|




|




















>


















>










>






|




|




|







5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
	    SHLIB_SUFFIX=".so"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS=""
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		CC_SEARCH_FLAGS=""
		LD_SEARCH_FLAGS=""
	    else
		ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
echo "configure:5996: checking for dld.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 6001 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6006: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
  echo "$ac_t""yes" 1>&6
  
		    SHLIB_LD="ld -shared"
		    DL_OBJS=""
		    DL_LIBS="-ldld"
		    LDFLAGS=""
		    CC_SEARCH_FLAGS=""
		    LD_SEARCH_FLAGS=""
else
  echo "$ac_t""no" 1>&6
fi

	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi
	    ;;
	MP-RAS-02*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	MP-RAS-*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-Wl,-Bexport"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[1-2].*|OpenBSD-*)
	    # Not available on all versions:  check for include file.
	    ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
echo "configure:6064: checking for dlfcn.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 6069 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6074: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
5943
5944
5945
5946
5947
5948
5949
5950

5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
		SHLIB_CFLAGS="-fPIC"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		LDFLAGS=""
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

		echo $ac_n "checking for ELF""... $ac_c" 1>&6
echo "configure:5953: checking for ELF" >&5
		cat > conftest.$ac_ext <<EOF
#line 5955 "configure"
#include "confdefs.h"

#ifdef __ELF__
	yes
#endif
		
EOF







|
>

|

|







6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
		SHLIB_CFLAGS="-fPIC"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		LDFLAGS=""
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
		echo $ac_n "checking for ELF""... $ac_c" 1>&6
echo "configure:6102: checking for ELF" >&5
		cat > conftest.$ac_ext <<EOF
#line 6104 "configure"
#include "confdefs.h"

#ifdef __ELF__
	yes
#endif
		
EOF
5979
5980
5981
5982
5983
5984
5985
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
		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		LDFLAGS=""
		LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    
fi


	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS="-export-dynamic"
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="-pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Rhapsody-*|Darwin-*)
            HACK_PART_1="-DMA"
            HACK_PART_2="C_OSX_TCL"
            EXTRA_CFLAGS="${HACK_PART_1}${HACK_PART_2} -DHAVE_CFBUNDLE"
	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS} "
            TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -framework CoreFoundation"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"
            PLAT_OBJS="tclMacOSXBundle.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    CFLAGS_OPTIMIZE="-Os"
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"


	    LIBS="$LIBS -framework CoreFoundation"
         EXTRA_CFLAGS='-DTCL_DEFAULT_ENCODING=\"utf-8\"'
	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	OS/390-*)
	    CFLAGS_OPTIMIZE=""      # Optimizer is buggy
	    cat >> confdefs.h <<\EOF
#define _OE_SOCKETS 1
EOF
  # needed in sys/socket.h
	    ;;      
	OSF1-1.0|OSF1-1.1|OSF1-1.2)
	    # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
	    SHLIB_CFLAGS=""
	    # Hack: make package name same as library name
	    SHLIB_LD='ld -R -export :'
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadOSF.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-1.*)
	    # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
	    SHLIB_CFLAGS="-fPIC"
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD="ld -shared"
	    else
	        SHLIB_LD="ld -non_shared"
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-V*)
	    # Digital OSF/1
	    SHLIB_CFLAGS=""
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD='ld -shared -expect_unresolved "*"'
	    else
	        SHLIB_LD='ld -non_shared -expect_unresolved "*"'
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    # see pthread_intro(3) for pthread support on osf1, k.furukawa
	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"







|
>



















|
>














<
<
<

|
|



|

|
>



>
>

<









>



















>















>















|
>







6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171



6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187

6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		LDFLAGS=""
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    
fi


	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS="-export-dynamic"
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="-pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Rhapsody-*|Darwin-*)



	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
	    TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${LIB_RUNTIME_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"
	    PLAT_OBJS="tclMacOSXBundle.o"
	    DL_LIBS=""
	    LDFLAGS="-prebind"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    CFLAGS_OPTIMIZE="-Os"
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
        HACK=""
	    EXTRA_CFLAGS="-DMA${HACK}C_OSX_TCL -DHAVE_CFBUNDLE -DTCL_DEFAULT_ENCODING=\\\"utf-8\\\""
	    LIBS="$LIBS -framework CoreFoundation"

	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OS/390-*)
	    CFLAGS_OPTIMIZE=""      # Optimizer is buggy
	    cat >> confdefs.h <<\EOF
#define _OE_SOCKETS 1
EOF
  # needed in sys/socket.h
	    ;;      
	OSF1-1.0|OSF1-1.1|OSF1-1.2)
	    # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
	    SHLIB_CFLAGS=""
	    # Hack: make package name same as library name
	    SHLIB_LD='ld -R -export :'
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadOSF.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-1.*)
	    # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
	    SHLIB_CFLAGS="-fPIC"
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD="ld -shared"
	    else
	        SHLIB_LD="ld -non_shared"
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-V*)
	    # Digital OSF/1
	    SHLIB_CFLAGS=""
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD='ld -shared -expect_unresolved "*"'
	    else
	        SHLIB_LD='ld -non_shared -expect_unresolved "*"'
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    # see pthread_intro(3) for pthread support on osf1, k.furukawa
	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
6118
6119
6120
6121
6122
6123
6124

6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
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
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="-melf -Wl,-Bexport"
	    else
	    	SHLIB_CFLAGS="-Kpic -belf"
	    	LDFLAGS="-belf -Wl,-Bexport"
	    fi
	    SHLIB_LD="ld -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	SINIX*5.4*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	SunOS-4*)
	    SHLIB_CFLAGS="-PIC"
	    SHLIB_LD="ld"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'


	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'







>










|
>

















>










>










|
>







6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="-melf -Wl,-Bexport"
	    else
	    	SHLIB_CFLAGS="-Kpic -belf"
	    	LDFLAGS="-belf -Wl,-Bexport"
	    fi
	    SHLIB_LD="ld -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	SINIX*5.4*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	SunOS-4*)
	    SHLIB_CFLAGS="-PIC"
	    SHLIB_LD="ld"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
6192
6193
6194
6195
6196
6197
6198
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

	    cat >> confdefs.h <<\EOF
#define _POSIX_PTHREAD_SEMANTICS 1
EOF


	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"

	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    if test "$GCC" = "yes" ; then

		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'

	    else

		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'

	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    cat >> confdefs.h <<\EOF
#define _REENTRANT 1
EOF

	    cat >> confdefs.h <<\EOF
#define _POSIX_PTHREAD_SEMANTICS 1
EOF


	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"
	    LDFLAGS=""
    
	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then







<










>
|
>

>
|
>

















<







6351
6352
6353
6354
6355
6356
6357

6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391

6392
6393
6394
6395
6396
6397
6398

	    cat >> confdefs.h <<\EOF
#define _POSIX_PTHREAD_SEMANTICS 1
EOF


	    SHLIB_CFLAGS="-KPIC"


	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    cat >> confdefs.h <<\EOF
#define _REENTRANT 1
EOF

	    cat >> confdefs.h <<\EOF
#define _POSIX_PTHREAD_SEMANTICS 1
EOF


	    SHLIB_CFLAGS="-KPIC"

	    LDFLAGS=""
    
	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then
6255
6256
6257
6258
6259
6260
6261

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
	    # 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

		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'

	    else


		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
	    # that don't grok the -Bexport option.  Test that it does.
	    hold_ldflags=$LDFLAGS
	    echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6
echo "configure:6292: checking for ld accepts -Bexport flag" >&5
	    LDFLAGS="${LDFLAGS} -Wl,-Bexport"
	    cat > conftest.$ac_ext <<EOF
#line 6295 "configure"
#include "confdefs.h"

int main() {
int i;
; return 0; }
EOF
if { (eval echo configure:6302: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  found=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  found=no
fi
rm -f conftest*
	    LDFLAGS=$hold_ldflags
	    echo "$ac_t""$found" 1>&6
	    if test $found = yes; then
	    LDFLAGS="-Wl,-Bexport"
	    else
	    LDFLAGS=""
	    fi

	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
    echo "configure: warning: "64bit support being disabled -- don\'t know magic for this platform"" 1>&2
    fi







>
|
>

>
>











|
>















|


|






|
















>







6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
	    # that don't grok the -Bexport option.  Test that it does.
	    hold_ldflags=$LDFLAGS
	    echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6
echo "configure:6458: checking for ld accepts -Bexport flag" >&5
	    LDFLAGS="${LDFLAGS} -Wl,-Bexport"
	    cat > conftest.$ac_ext <<EOF
#line 6461 "configure"
#include "confdefs.h"

int main() {
int i;
; return 0; }
EOF
if { (eval echo configure:6468: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  rm -rf conftest*
  found=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  found=no
fi
rm -f conftest*
	    LDFLAGS=$hold_ldflags
	    echo "$ac_t""$found" 1>&6
	    if test $found = yes; then
	    LDFLAGS="-Wl,-Bexport"
	    else
	    LDFLAGS=""
	    fi
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
    echo "configure: warning: "64bit support being disabled -- don\'t know magic for this platform"" 1>&2
    fi
6340
6341
6342
6343
6344
6345
6346
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
    #
    # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
    # `struct exec' includes a second header that contains information that
    # duplicates the v7 fields that are needed.

    if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
	echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
echo "configure:6348: checking sys/exec.h" >&5
	cat > conftest.$ac_ext <<EOF
#line 6350 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() {

	    struct exec foo;
	    unsigned long seek;
	    int flag;
#if defined(__mips) || defined(mips)
	    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
	    seek = N_TXTOFF (foo);
#endif
	    flag = (foo.a_magic == OMAGIC);
	    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
    
; return 0; }
EOF
if { (eval echo configure:6368: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_ok=usable
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=unusable
fi
rm -f conftest*
	echo "$ac_t""$tcl_ok" 1>&6
	if test $tcl_ok = usable; then
	    cat >> confdefs.h <<\EOF
#define USE_SYS_EXEC_H 1
EOF

	else
	    echo $ac_n "checking a.out.h""... $ac_c" 1>&6
echo "configure:6386: checking a.out.h" >&5
	    cat > conftest.$ac_ext <<EOF
#line 6388 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() {

		struct exec foo;
		unsigned long seek;
		int flag;
#if defined(__mips) || defined(mips)
		seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		seek = N_TXTOFF (foo);
#endif
		flag = (foo.a_magic == OMAGIC);
		return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
	    
; return 0; }
EOF
if { (eval echo configure:6406: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_ok=usable
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=unusable
fi
rm -f conftest*
	    echo "$ac_t""$tcl_ok" 1>&6
	    if test $tcl_ok = usable; then
		cat >> confdefs.h <<\EOF
#define USE_A_OUT_H 1
EOF

	    else
		echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
echo "configure:6424: checking sys/exec_aout.h" >&5
		cat > conftest.$ac_ext <<EOF
#line 6426 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() {

		    struct exec foo;
		    unsigned long seek;
		    int flag;
#if defined(__mips) || defined(mips)
		    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		    seek = N_TXTOFF (foo);
#endif
		    flag = (foo.a_midmag == OMAGIC);
		    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
		
; return 0; }
EOF
if { (eval echo configure:6444: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_ok=usable
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=unusable







|

|

















|

















|

|

















|

















|

|

















|







6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
    #
    # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
    # `struct exec' includes a second header that contains information that
    # duplicates the v7 fields that are needed.

    if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
	echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
echo "configure:6515: checking sys/exec.h" >&5
	cat > conftest.$ac_ext <<EOF
#line 6517 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() {

	    struct exec foo;
	    unsigned long seek;
	    int flag;
#if defined(__mips) || defined(mips)
	    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
	    seek = N_TXTOFF (foo);
#endif
	    flag = (foo.a_magic == OMAGIC);
	    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
    
; return 0; }
EOF
if { (eval echo configure:6535: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_ok=usable
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=unusable
fi
rm -f conftest*
	echo "$ac_t""$tcl_ok" 1>&6
	if test $tcl_ok = usable; then
	    cat >> confdefs.h <<\EOF
#define USE_SYS_EXEC_H 1
EOF

	else
	    echo $ac_n "checking a.out.h""... $ac_c" 1>&6
echo "configure:6553: checking a.out.h" >&5
	    cat > conftest.$ac_ext <<EOF
#line 6555 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() {

		struct exec foo;
		unsigned long seek;
		int flag;
#if defined(__mips) || defined(mips)
		seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		seek = N_TXTOFF (foo);
#endif
		flag = (foo.a_magic == OMAGIC);
		return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
	    
; return 0; }
EOF
if { (eval echo configure:6573: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_ok=usable
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=unusable
fi
rm -f conftest*
	    echo "$ac_t""$tcl_ok" 1>&6
	    if test $tcl_ok = usable; then
		cat >> confdefs.h <<\EOF
#define USE_A_OUT_H 1
EOF

	    else
		echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
echo "configure:6591: checking sys/exec_aout.h" >&5
		cat > conftest.$ac_ext <<EOF
#line 6593 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() {

		    struct exec foo;
		    unsigned long seek;
		    int flag;
#if defined(__mips) || defined(mips)
		    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		    seek = N_TXTOFF (foo);
#endif
		    flag = (foo.a_midmag == OMAGIC);
		    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
		
; return 0; }
EOF
if { (eval echo configure:6611: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  tcl_ok=usable
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  tcl_ok=unusable
6484
6485
6486
6487
6488
6489
6490

6491
6492
6493
6494
6495
6496
6497
	echo "on this system."
	SHLIB_CFLAGS=""
	SHLIB_LD=""
	SHLIB_SUFFIX=""
	DL_OBJS="tclLoadNone.o"
	DL_LIBS=""
	LDFLAGS=""

	LD_SEARCH_FLAGS=""
	BUILD_DLTEST=""
    fi

    # If we're running gcc, then change the C flags for compiling shared
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.







>







6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
	echo "on this system."
	SHLIB_CFLAGS=""
	SHLIB_LD=""
	SHLIB_SUFFIX=""
	DL_OBJS="tclLoadNone.o"
	DL_LIBS=""
	LDFLAGS=""
	CC_SEARCH_FLAGS=""
	LD_SEARCH_FLAGS=""
	BUILD_DLTEST=""
    fi

    # If we're running gcc, then change the C flags for compiling shared
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.
6526
6527
6528
6529
6530
6531
6532
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
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi

    
    






    







    













































    echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:6541: checking for build with symbols" >&5
    # Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
  enableval="$enable_symbols"
  tcl_ok=$enableval
else
  tcl_ok=no
fi

# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
    if test "$tcl_ok" = "yes"; then
	CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
	LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
	DBGX=g
	echo "$ac_t""yes" 1>&6
    else
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
	DBGX=""
	echo "$ac_t""no" 1>&6
    fi




TCL_DBGX=${DBGX}

#--------------------------------------------------------------------
#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.
#--------------------------------------------------------------------


    for ac_hdr in sys/ioctl.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:6578: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 6583 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6588: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|
>
>
>
>
>
>
|
>
>
>
>
>
>
>
|
>


>
>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|




















>
>
















|




|




|







6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi

    

    if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
        LIB_SUFFIX=${SHARED_LIB_SUFFIX}
        MAKE_LIB='${SHLIB_LD} -o $@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
        INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
    else
        LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}

        if test "$RANLIB" = "" ; then
            MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
        else
            MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))'
        fi

    fi


    # Stub lib does not depend on shared/static configuration
    if test "$RANLIB" = "" ; then
        MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
        INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)'
    else
        MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
        INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))'
    fi


    

    
    
    
    
    
    
    

    
    
    
    
    

    
    
    
    
    
    
    

    
    
    
    
    



    echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:6764: checking for build with symbols" >&5
    # Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
  enableval="$enable_symbols"
  tcl_ok=$enableval
else
  tcl_ok=no
fi

# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
    if test "$tcl_ok" = "yes"; then
	CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
	LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
	DBGX=g
	echo "$ac_t""yes" 1>&6
    else
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
	DBGX=""
	echo "$ac_t""no" 1>&6
    fi
    
    


TCL_DBGX=${DBGX}

#--------------------------------------------------------------------
#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.
#--------------------------------------------------------------------


    for ac_hdr in sys/ioctl.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:6803: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 6808 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6813: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
fi
done

    for ac_hdr in sys/filio.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:6618: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 6623 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6628: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
fi
done

    for ac_hdr in sys/filio.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:6843: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 6848 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6853: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
 
else
  echo "$ac_t""no" 1>&6
fi
done

    echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6
echo "configure:6655: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
    if test -f /usr/lib/NextStep/software_version; then
	system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
    else
	system=`uname -s`-`uname -r`
	if test "$?" -ne 0 ; then
	    system=unknown
	else







|







6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
 
else
  echo "$ac_t""no" 1>&6
fi
done

    echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6
echo "configure:6880: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
    if test -f /usr/lib/NextStep/software_version; then
	system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
    else
	system=`uname -s`-`uname -r`
	if test "$?" -ne 0 ; then
	    system=unknown
	else
6706
6707
6708
6709
6710
6711
6712
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
#--------------------------------------------------------------------
#	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}


    echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:6717: checking how to build libraries" >&5
    # Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
  enableval="$enable_shared"
  tcl_ok=$enableval
else
  tcl_ok=yes
fi


    if test "${enable_shared+set}" = set; then
	enableval="$enable_shared"
	tcl_ok=$enableval
    else
	tcl_ok=yes
    fi

    if test "$tcl_ok" = "yes" ; then
	echo "$ac_t""shared" 1>&6
	SHARED_BUILD=1
    else
	echo "$ac_t""static" 1>&6
	SHARED_BUILD=0
	cat >> confdefs.h <<\EOF
#define STATIC_BUILD 1
EOF

    fi


    echo $ac_n "checking how to package libraries""... $ac_c" 1>&6
echo "configure:6748: checking how to package libraries" >&5
    # Check whether --enable-framework or --disable-framework was given.
if test "${enable_framework+set}" = set; then
  enableval="$enable_framework"
  tcl_ok=$enableval
else
  tcl_ok=no
fi


    if test "${enable_framework+set}" = set; then
	enableval="$enable_framework"
	tcl_ok=$enableval
    else
	tcl_ok=no
    fi

    if test "$tcl_ok" = "yes" ; then


        if test "${SHARED_BUILD}" = "0" ; then
            { echo "configure: error: "Frameworks can only be built if --enable-shared is yes"" 1>&2; exit 1; }

        fi
	echo "$ac_t""framework" 1>&6
	FRAMEWORK_BUILD=1
    else
	echo "$ac_t""standard shared library" 1>&6
	FRAMEWORK_BUILD=0
    fi


TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != "" ; then
    TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}"
    eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}"
    if test "x$DL_OBJS" = "xtclLoadAout.o"; then
	MAKE_LIB="\${STLIB_LD} \$@ \${OBJS}"
    else
	MAKE_LIB="\${SHLIB_LD} ${TCL_SHLIB_LD_EXTRAS} -o \$@ \${OBJS} ${SHLIB_LD_LIBS}"
    fi
else
    case $system in
        BSD/OS*)
	    ;;

	AIX-[1-4].*)
            ;;

        *)
	    SHLIB_LD_LIBS=""
	    ;;
    esac
    TCL_SHLIB_CFLAGS=""
    eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}"
    MAKE_LIB="\${STLIB_LD} \$@ \${OBJS}"
fi

# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.

# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-framework Tcl"
    TCL_LIB_FILE="Tcl"
elif test "$SHARED_BUILD" = "0" -o $TCL_NEEDS_EXP_FILE = 0; then
    if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
        TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
    else
        TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
    fi
    TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
    TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"







|

<
<
<
<
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|

















>
>
|
|
>
|
<
<






<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















|







6931
6932
6933
6934
6935
6936
6937
6938
6939









6940





















6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965


6966
6967
6968
6969
6970
6971


























6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
#--------------------------------------------------------------------
#	The statements below define a collection of symbols related to
#	building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------

TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
































    echo $ac_n "checking how to package libraries""... $ac_c" 1>&6
echo "configure:6943: checking how to package libraries" >&5
    # Check whether --enable-framework or --disable-framework was given.
if test "${enable_framework+set}" = set; then
  enableval="$enable_framework"
  tcl_ok=$enableval
else
  tcl_ok=no
fi


    if test "${enable_framework+set}" = set; then
	enableval="$enable_framework"
	tcl_ok=$enableval
    else
	tcl_ok=no
    fi

    if test "$tcl_ok" = "yes" ; then
	echo "$ac_t""framework" 1>&6
	FRAMEWORK_BUILD=1
	if test "${SHARED_BUILD}" = "0" ; then
	    echo "configure: warning: "Frameworks can only be built if --enable-shared is yes"" 1>&2
	    FRAMEWORK_BUILD=0
	fi


    else
	echo "$ac_t""standard shared library" 1>&6
	FRAMEWORK_BUILD=0
    fi




























# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.

# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-framework Tcl"
    TCL_LIB_FILE="Tcl"
elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
    if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
        TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
    else
        TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
    fi
    TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
    TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
6848
6849
6850
6851
6852
6853
6854
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
#	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="${prefix}/Tcl.framework/Versions/${TCL_VERSION}/Resources/Scripts"
elif test "$prefix" != "$exec_prefix"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
    if test "$prefix" != "$exec_prefix"; then
        TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib"
    else
        TCL_PACKAGE_PATH="${prefix}/lib"
    fi
fi

#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""

MAKE_STUB_LIB="\${STLIB_LD} \$@ \${STUB_LIB_OBJS}"

if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_STUB_LIB_SPEC="-L${exec_prefix}/Tcl.framework/Versions/${TCL_VERSION} ${TCL_STUB_LIB_FLAG}"
    TCL_STUB_LIB_PATH="${exec_prefix}/Tcl.framework/Versions/${TCL_VERSION}/${TCL_STUB_LIB_FILE}"
else
    TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"
    TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"

fi

TCL_BUILD_STUB_LIB_PATH="`pwd`/${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}






































|



<
<
<
|
<












<
<







<
<
<
<
|
<
<
<
<

>









<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028



7029

7030
7031
7032
7033
7034
7035
7036
7037
7038
7039
7040
7041


7042
7043
7044
7045
7046
7047
7048




7049




7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
























7061
7062
7063
7064
7065
7066
7067
#	The statements below define the symbol TCL_PACKAGE_PATH, which
#	gives a list of directories that may contain packages.  The list
#	consists of one directory for machine-dependent binaries and
#	another for platform-independent scripts.
#--------------------------------------------------------------------

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_PACKAGE_PATH="${libdir}/Resources/Scripts"
elif test "$prefix" != "$exec_prefix"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else



    TCL_PACKAGE_PATH="${prefix}/lib"

fi

#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""



if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"




TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"




TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"

# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""

#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------

TCL_SHARED_BUILD=${SHARED_BUILD}































7105
7106
7107
7108
7109
7110
7111

7112
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
s%@sharedstatedir@%$sharedstatedir%g
s%@localstatedir@%$localstatedir%g
s%@libdir@%$libdir%g
s%@includedir@%$includedir%g
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g

s%@CC@%$CC%g
s%@RANLIB@%$RANLIB%g
s%@CPP@%$CPP%g
s%@TCL_THREADS@%$TCL_THREADS%g
s%@LIBOBJS@%$LIBOBJS%g
s%@TCL_LIBS@%$TCL_LIBS%g
s%@MATH_LIBS@%$MATH_LIBS%g
s%@AR@%$AR%g

s%@DL_LIBS@%$DL_LIBS%g


s%@CFLAGS_DEBUG@%$CFLAGS_DEBUG%g
s%@CFLAGS_OPTIMIZE@%$CFLAGS_OPTIMIZE%g
s%@CFLAGS_WARNING@%$CFLAGS_WARNING%g


















s%@TCL_VERSION@%$TCL_VERSION%g
s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g
s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g
s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g
s%@TCL_LIB_FLAG@%$TCL_LIB_FLAG%g
s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g
s%@TCL_STUB_LIB_FILE@%$TCL_STUB_LIB_FILE%g
s%@TCL_STUB_LIB_FLAG@%$TCL_STUB_LIB_FLAG%g
s%@TCL_STUB_LIB_SPEC@%$TCL_STUB_LIB_SPEC%g
s%@TCL_STUB_LIB_PATH@%$TCL_STUB_LIB_PATH%g
s%@TCL_INCLUDE_SPEC@%$TCL_INCLUDE_SPEC%g
s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g
s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g
s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
s%@TCL_BIN_DIR@%$TCL_BIN_DIR%g
s%@TCL_DBGX@%$TCL_DBGX%g
s%@CFG_TCL_SHARED_LIB_SUFFIX@%$CFG_TCL_SHARED_LIB_SUFFIX%g
s%@CFG_TCL_UNSHARED_LIB_SUFFIX@%$CFG_TCL_UNSHARED_LIB_SUFFIX%g
s%@CFG_TCL_EXPORT_FILE_SUFFIX@%$CFG_TCL_EXPORT_FILE_SUFFIX%g
s%@DL_OBJS@%$DL_OBJS%g
s%@PLAT_OBJS@%$PLAT_OBJS%g
s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g
s%@EXTRA_CFLAGS@%$EXTRA_CFLAGS%g
s%@LD_LIBRARY_PATH_VAR@%$LD_LIBRARY_PATH_VAR%g
s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g
s%@LDFLAGS_DEBUG@%$LDFLAGS_DEBUG%g
s%@LDFLAGS_OPTIMIZE@%$LDFLAGS_OPTIMIZE%g
s%@STLIB_LD@%$STLIB_LD%g
s%@SHLIB_LD@%$SHLIB_LD%g
s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g
s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g
s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g
s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g
s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g
s%@TCL_LD_SEARCH_FLAGS@%$TCL_LD_SEARCH_FLAGS%g
s%@TCL_NEEDS_EXP_FILE@%$TCL_NEEDS_EXP_FILE%g
s%@TCL_BUILD_EXP_FILE@%$TCL_BUILD_EXP_FILE%g
s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g
s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g
s%@TCL_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g
s%@TCL_SHLIB_CFLAGS@%$TCL_SHLIB_CFLAGS%g
s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g
s%@TCL_HAS_LONGLONG@%$TCL_HAS_LONGLONG%g
s%@MAKE_LIB@%$MAKE_LIB%g
s%@MAKE_STUB_LIB@%$MAKE_STUB_LIB%g
s%@BUILD_DLTEST@%$BUILD_DLTEST%g
s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g

CEOF
EOF

cat >> $CONFIG_STATUS <<\EOF







>

<






>

>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>















<




|
<
<
<

<
<
<
<
<
<
<
<
<

<





<


<
<







7238
7239
7240
7241
7242
7243
7244
7245
7246

7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292

7293
7294
7295
7296
7297



7298









7299

7300
7301
7302
7303
7304

7305
7306


7307
7308
7309
7310
7311
7312
7313
s%@sharedstatedir@%$sharedstatedir%g
s%@localstatedir@%$localstatedir%g
s%@libdir@%$libdir%g
s%@includedir@%$includedir%g
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
s%@MKLINKS_FLAGS@%$MKLINKS_FLAGS%g
s%@CC@%$CC%g

s%@CPP@%$CPP%g
s%@TCL_THREADS@%$TCL_THREADS%g
s%@LIBOBJS@%$LIBOBJS%g
s%@TCL_LIBS@%$TCL_LIBS%g
s%@MATH_LIBS@%$MATH_LIBS%g
s%@AR@%$AR%g
s%@RANLIB@%$RANLIB%g
s%@DL_LIBS@%$DL_LIBS%g
s%@DL_OBJS@%$DL_OBJS%g
s%@PLAT_OBJS@%$PLAT_OBJS%g
s%@CFLAGS_DEBUG@%$CFLAGS_DEBUG%g
s%@CFLAGS_OPTIMIZE@%$CFLAGS_OPTIMIZE%g
s%@CFLAGS_WARNING@%$CFLAGS_WARNING%g
s%@EXTRA_CFLAGS@%$EXTRA_CFLAGS%g
s%@LDFLAGS_DEBUG@%$LDFLAGS_DEBUG%g
s%@LDFLAGS_OPTIMIZE@%$LDFLAGS_OPTIMIZE%g
s%@CC_SEARCH_FLAGS@%$CC_SEARCH_FLAGS%g
s%@LD_SEARCH_FLAGS@%$LD_SEARCH_FLAGS%g
s%@STLIB_LD@%$STLIB_LD%g
s%@SHLIB_LD@%$SHLIB_LD%g
s%@TCL_SHLIB_LD_EXTRAS@%$TCL_SHLIB_LD_EXTRAS%g
s%@SHLIB_LD_FLAGS@%$SHLIB_LD_FLAGS%g
s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g
s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g
s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g
s%@MAKE_LIB@%$MAKE_LIB%g
s%@MAKE_STUB_LIB@%$MAKE_STUB_LIB%g
s%@INSTALL_LIB@%$INSTALL_LIB%g
s%@INSTALL_STUB_LIB@%$INSTALL_STUB_LIB%g
s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g
s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g
s%@TCL_VERSION@%$TCL_VERSION%g
s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g
s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g
s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g
s%@TCL_LIB_FLAG@%$TCL_LIB_FLAG%g
s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g
s%@TCL_STUB_LIB_FILE@%$TCL_STUB_LIB_FILE%g
s%@TCL_STUB_LIB_FLAG@%$TCL_STUB_LIB_FLAG%g
s%@TCL_STUB_LIB_SPEC@%$TCL_STUB_LIB_SPEC%g
s%@TCL_STUB_LIB_PATH@%$TCL_STUB_LIB_PATH%g
s%@TCL_INCLUDE_SPEC@%$TCL_INCLUDE_SPEC%g
s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g
s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g
s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g

s%@TCL_DBGX@%$TCL_DBGX%g
s%@CFG_TCL_SHARED_LIB_SUFFIX@%$CFG_TCL_SHARED_LIB_SUFFIX%g
s%@CFG_TCL_UNSHARED_LIB_SUFFIX@%$CFG_TCL_UNSHARED_LIB_SUFFIX%g
s%@CFG_TCL_EXPORT_FILE_SUFFIX@%$CFG_TCL_EXPORT_FILE_SUFFIX%g
s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g



s%@LD_LIBRARY_PATH_VAR@%$LD_LIBRARY_PATH_VAR%g









s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g

s%@TCL_NEEDS_EXP_FILE@%$TCL_NEEDS_EXP_FILE%g
s%@TCL_BUILD_EXP_FILE@%$TCL_BUILD_EXP_FILE%g
s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g
s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g
s%@TCL_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g

s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g
s%@TCL_HAS_LONGLONG@%$TCL_HAS_LONGLONG%g


s%@BUILD_DLTEST@%$BUILD_DLTEST%g
s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g

CEOF
EOF

cat >> $CONFIG_STATUS <<\EOF
Changes to unix/configure.in.
1
2
3
4
5
6
7
8

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28





29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#! /bin/bash -norc
dnl	This file is an input file used by the GNU "autoconf" program to
dnl	generate the file "configure", which is run during Tcl installation
dnl	to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.72.8.5 2002/06/10 05:33:18 wolfsuit Exp $

AC_INIT(../generic/tcl.h)


TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="a5"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`






#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------

# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
    CFLAGS=""
fi

AC_PROG_CC
AC_PROG_RANLIB
AC_HAVE_HEADERS(unistd.h limits.h)

#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------

SC_ENABLE_THREADS





|


>




|















>
>
>
>
>












<







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

47
48
49
50
51
52
53
#! /bin/bash -norc
dnl	This file is an input file used by the GNU "autoconf" program to
dnl	generate the file "configure", which is run during Tcl installation
dnl	to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.72.8.6 2002/08/20 20:25:30 das Exp $

AC_INIT(../generic/tcl.h)
AC_PREREQ(2.13)

TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="b3"
VERSION=${TCL_VERSION}

#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------

if test "${prefix}" = "NONE"; then
    prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
    exec_prefix=$prefix
fi
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`

#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
SC_CONFIG_MANPAGES

#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------

# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
    CFLAGS=""
fi

AC_PROG_CC

AC_HAVE_HEADERS(unistd.h limits.h)

#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------

SC_ENABLE_THREADS
257
258
259
260
261
262
263
















264
265
266
267
268
269
270
#	they don't exist.
#--------------------------------------------------------------------

AC_TYPE_MODE_T
AC_TYPE_PID_T
AC_TYPE_SIZE_T
AC_TYPE_UID_T

















#--------------------------------------------------------------------
#	If a system doesn't have an opendir function (man, that's old!)
#	then we have to supply a different version of dirent.h which
#	is compatible with the substitute version of opendir that's
#	provided.  This version only works with V7-style directories.
#--------------------------------------------------------------------







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
#	they don't exist.
#--------------------------------------------------------------------

AC_TYPE_MODE_T
AC_TYPE_PID_T
AC_TYPE_SIZE_T
AC_TYPE_UID_T

AC_MSG_CHECKING([for socklen_t])
AC_CACHE_VAL(ac_cv_type_socklen_t,
[AC_EGREP_CPP(changequote(<<,>>)dnl
<<(^|[^a-zA-Z_0-9])socklen_t[^a-zA-Z_0-9]>>dnl
changequote([,]),[#include <sys/types.h>
#include <sys/socket.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif], ac_cv_type_socklen_t=yes, ac_cv_type_socklen_t=no)
AC_MSG_RESULT($ac_cv_type_socklen_t)
if test $ac_cv_type_socklen_t = no; then
  AC_DEFINE(socklen_t, unsigned)
fi
])

#--------------------------------------------------------------------
#	If a system doesn't have an opendir function (man, that's old!)
#	then we have to supply a different version of dirent.h which
#	is compatible with the substitute version of opendir that's
#	provided.  This version only works with V7-style directories.
#--------------------------------------------------------------------
362
363
364
365
366
367
368


369
370
371
372
373
374
375
#--------------------------------------------------------------------

SC_TCL_LINK_LIBS

# Add the threads support libraries

LIBS="$LIBS$THREADS_LIBS"



#--------------------------------------------------------------------
# The statements below define a collection of compile flags.  This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------








>
>







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
#--------------------------------------------------------------------

SC_TCL_LINK_LIBS

# Add the threads support libraries

LIBS="$LIBS$THREADS_LIBS"

SC_ENABLE_SHARED

#--------------------------------------------------------------------
# The statements below define a collection of compile flags.  This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------

391
392
393
394
395
396
397
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
#--------------------------------------------------------------------
#	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}

SC_ENABLE_SHARED
SC_ENABLE_FRAMEWORK

TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != "" ; then
    TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}"
    eval "TCL_LIB_FILE=libtcl${TCL_SHARED_LIB_SUFFIX}"
    if test "x$DL_OBJS" = "xtclLoadAout.o"; then
	MAKE_LIB="\${STLIB_LD} \[$]@ \${OBJS}"
    else
	MAKE_LIB="\${SHLIB_LD} ${TCL_SHLIB_LD_EXTRAS} -o \[$]@ \${OBJS} ${SHLIB_LD_LIBS}"
    fi
else
    case $system in
        BSD/OS*)
	    ;;

	AIX-[[1-4]].*)
            ;;

        *)
	    SHLIB_LD_LIBS=""
	    ;;
    esac
    TCL_SHLIB_CFLAGS=""
    eval "TCL_LIB_FILE=libtcl${TCL_UNSHARED_LIB_SUFFIX}"
    MAKE_LIB="\${STLIB_LD} \[$]@ \${OBJS}"
fi

# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.

# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-framework Tcl"
    TCL_LIB_FILE="Tcl"
elif test "$SHARED_BUILD" = "0" -o $TCL_NEEDS_EXP_FILE = 0; then
    if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
        TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
    else
        TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
    fi
    TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
    TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"







<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<

<
<
|
<
<
<
<
<
<
<
<

















|







414
415
416
417
418
419
420







421









422


423








424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
#--------------------------------------------------------------------
#	The statements below define a collection of symbols related to
#	building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------

TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}







eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"












SC_ENABLE_FRAMEWORK









# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.

# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"

# Note:  in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..":  this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
    TCL_LIB_SPEC="-framework Tcl"
    TCL_LIB_FILE="Tcl"
elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
    if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
        TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
    else
        TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
    fi
    TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
    TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
474
475
476
477
478
479
480
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
#	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="${prefix}/Tcl.framework/Versions/${TCL_VERSION}/Resources/Scripts"
elif test "$prefix" != "$exec_prefix"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
    if test "$prefix" != "$exec_prefix"; then
        TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib"
    else
        TCL_PACKAGE_PATH="${prefix}/lib"
    fi
fi

#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""

MAKE_STUB_LIB="\${STLIB_LD} \[$]@ \${STUB_LIB_OBJS}"

if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_STUB_LIB_SPEC="-L${exec_prefix}/Tcl.framework/Versions/${TCL_VERSION} ${TCL_STUB_LIB_FLAG}"
    TCL_STUB_LIB_PATH="${exec_prefix}/Tcl.framework/Versions/${TCL_VERSION}/${TCL_STUB_LIB_FILE}"
else
    TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"
    TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"

fi

TCL_BUILD_STUB_LIB_PATH="`pwd`/${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
#------------------------------------------------------------------------







|



<
<
<
|
<












<
<







<
<
<
<
|
<
<
<
<

>







471
472
473
474
475
476
477
478
479
480
481



482

483
484
485
486
487
488
489
490
491
492
493
494


495
496
497
498
499
500
501




502




503
504
505
506
507
508
509
510
511
#	The statements below define the symbol TCL_PACKAGE_PATH, which
#	gives a list of directories that may contain packages.  The list
#	consists of one directory for machine-dependent binaries and
#	another for platform-independent scripts.
#--------------------------------------------------------------------

if test "$FRAMEWORK_BUILD" = "1" ; then
    TCL_PACKAGE_PATH="${libdir}/Resources/Scripts"
elif test "$prefix" != "$exec_prefix"; then
    TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else



    TCL_PACKAGE_PATH="${prefix}/lib"

fi

#--------------------------------------------------------------------
#       The statements below define various symbols relating to Tcl
#       stub support.
#--------------------------------------------------------------------

# Replace ${VERSION} with contents of ${TCL_VERSION}
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""



if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
    TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
    TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi

TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"




TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"




TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"

# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""

#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
541
542
543
544
545
546
547
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
AC_SUBST(TCL_STUB_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_PATH)
AC_SUBST(TCL_INCLUDE_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_PATH)

AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_DBGX)
AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)
AC_SUBST(TCL_DBGX)
AC_SUBST(DL_OBJS)
AC_SUBST(PLAT_OBJS)

AC_SUBST(CFLAGS)
AC_SUBST(CFLAGS_DEFAULT)
AC_SUBST(EXTRA_CFLAGS)
AC_SUBST(LD_LIBRARY_PATH_VAR)

AC_SUBST(LDFLAGS)
AC_SUBST(LDFLAGS_DEFAULT)
AC_SUBST(LDFLAGS_DEBUG)
AC_SUBST(LDFLAGS_OPTIMIZE)
AC_SUBST(AR)
AC_SUBST(RANLIB)

AC_SUBST(STLIB_LD)
AC_SUBST(SHLIB_LD)
AC_SUBST(SHLIB_LD_LIBS)
AC_SUBST(SHLIB_CFLAGS)
AC_SUBST(SHLIB_SUFFIX)
AC_SUBST(TCL_SHARED_BUILD)

AC_SUBST(TCL_BUILD_LIB_SPEC)
AC_SUBST(TCL_LD_SEARCH_FLAGS)
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_SHLIB_CFLAGS)
AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)

AC_SUBST(TCL_HAS_LONGLONG)

AC_SUBST(MAKE_LIB)
AC_SUBST(MAKE_STUB_LIB)
AC_SUBST(BUILD_DLTEST)
AC_SUBST(TCL_PACKAGE_PATH)

AC_OUTPUT(Makefile dltest/Makefile tclConfig.sh)







<




<
<
<

|
<
<


<
<
<
<
<
<
<
<
<
<
<
<
<
<

<






<




<
<




525
526
527
528
529
530
531

532
533
534
535



536
537


538
539














540

541
542
543
544
545
546

547
548
549
550


551
552
553
554
AC_SUBST(TCL_STUB_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_PATH)
AC_SUBST(TCL_INCLUDE_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
AC_SUBST(TCL_BUILD_STUB_LIB_PATH)

AC_SUBST(TCL_SRC_DIR)

AC_SUBST(TCL_DBGX)
AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)




AC_SUBST(TCL_SHARED_BUILD)


AC_SUBST(LD_LIBRARY_PATH_VAR)















AC_SUBST(TCL_BUILD_LIB_SPEC)

AC_SUBST(TCL_NEEDS_EXP_FILE)
AC_SUBST(TCL_BUILD_EXP_FILE)
AC_SUBST(TCL_EXP_FILE)

AC_SUBST(TCL_LIB_VERSIONS_OK)
AC_SUBST(TCL_SHARED_LIB_SUFFIX)

AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)

AC_SUBST(TCL_HAS_LONGLONG)



AC_SUBST(BUILD_DLTEST)
AC_SUBST(TCL_PACKAGE_PATH)

AC_OUTPUT(Makefile dltest/Makefile tclConfig.sh)
Changes to unix/dltest/Makefile.in.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
# This Makefile is used to create several test cases for Tcl's load
# command.  It also illustrates how to take advantage of configuration
# exported by Tcl to set up Makefiles for shared libraries.
# RCS: @(#) $Id: Makefile.in,v 1.6.18.2 2002/06/10 05:33:19 wolfsuit Exp $

TCL_DBGX =		@TCL_DBGX@
CC = @CC@
LIBS =			@TCL_BUILD_STUB_LIB_SPEC@ @DL_LIBS@ @LIBS@ @MATH_LIBS@
AC_FLAGS =		@EXTRA_CFLAGS@
SHLIB_CFLAGS =		@SHLIB_CFLAGS@
SHLIB_LD =		@SHLIB_LD@
SHLIB_LD_LIBS =		@SHLIB_LD_LIBS@
SHLIB_SUFFIX =		@SHLIB_SUFFIX@
SRC_DIR =		@srcdir@
TCL_VERSION=		@TCL_VERSION@

CFLAGS_DEBUG		= @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE		= @CFLAGS_OPTIMIZE@

CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
	${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}

all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX}


pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c
	$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c
	${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS}

pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c
	$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c



|




















>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
# This Makefile is used to create several test cases for Tcl's load
# command.  It also illustrates how to take advantage of configuration
# exported by Tcl to set up Makefiles for shared libraries.
# RCS: @(#) $Id: Makefile.in,v 1.6.18.3 2002/08/20 20:25:31 das Exp $

TCL_DBGX =		@TCL_DBGX@
CC = @CC@
LIBS =			@TCL_BUILD_STUB_LIB_SPEC@ @DL_LIBS@ @LIBS@ @MATH_LIBS@
AC_FLAGS =		@EXTRA_CFLAGS@
SHLIB_CFLAGS =		@SHLIB_CFLAGS@
SHLIB_LD =		@SHLIB_LD@
SHLIB_LD_LIBS =		@SHLIB_LD_LIBS@
SHLIB_SUFFIX =		@SHLIB_SUFFIX@
SRC_DIR =		@srcdir@
TCL_VERSION=		@TCL_VERSION@

CFLAGS_DEBUG		= @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE		= @CFLAGS_OPTIMIZE@

CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
	${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}

all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX}
	@touch ../dltest.marker

pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c
	$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c
	${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS}

pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c
	$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c
40
41
42
43
44
45
46
47

48
49
50
	${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}

pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c
	$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
	${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}

clean:
	rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status lib.exp


distclean: clean
	rm -f Makefile







|
>



41
42
43
44
45
46
47
48
49
50
51
52
	${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}

pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c
	$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
	${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}

clean:
	rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status
	rm -f lib.exp ../dltest.marker

distclean: clean
	rm -f Makefile
Changes to unix/mkLinks.
10
11
12
13
14
15
16
17
















18
19
20
21







22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


37
38
39
40
41
42


43
44
45
46
47
48
49
50
51
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
# Because of the length of command and procedure names, this mechanism
# only works on machines that support file names longer than 14 characters.
# This script checks to see if long file names are supported, and it
# doesn't make any links if they are not.
#
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.

















if test $# != 1; then
    echo "Usage: mkLinks dir"
    exit 1
fi








cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
echo foo > xyzzyTestingaverylongfilename.foo
y=`echo xyzzyTestingav*`
rm xyzzyTe*
if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then
    exit
fi
if test "$y" != "xyzzyTestingaverylongfilename.foo"; then
    CASEINSENSITIVEFS=1
fi

if test -r Access.3; then


    rm -f Tcl_Access.3
    rm -f Tcl_Stat.3
    ln Access.3 Tcl_Access.3
    ln Access.3 Tcl_Stat.3
fi
if test -r AddErrInfo.3; then


    rm -f Tcl_AddObjErrorInfo.3
    rm -f Tcl_AddErrorInfo.3
    rm -f Tcl_SetObjErrorCode.3
    rm -f Tcl_SetErrorCode.3
    rm -f Tcl_SetErrorCodeVA.3
    rm -f Tcl_PosixError.3
    rm -f Tcl_LogCommandInfo.3
    ln AddErrInfo.3 Tcl_AddObjErrorInfo.3
    ln AddErrInfo.3 Tcl_AddErrorInfo.3
    ln AddErrInfo.3 Tcl_SetObjErrorCode.3
    ln AddErrInfo.3 Tcl_SetErrorCode.3
    ln AddErrInfo.3 Tcl_SetErrorCodeVA.3
    ln AddErrInfo.3 Tcl_PosixError.3
    ln AddErrInfo.3 Tcl_LogCommandInfo.3
fi
if test -r Alloc.3; then


    rm -f Tcl_Alloc.3
    rm -f Tcl_Free.3
    rm -f Tcl_Realloc.3
    rm -f Tcl_AttemptAlloc.3
    rm -f Tcl_AttemptRealloc.3
    rm -f ckalloc.3
    rm -f ckfree.3
    rm -f ckrealloc.3
    rm -f attemptckalloc.3
    rm -f attemptckrealloc.3
    ln Alloc.3 Tcl_Alloc.3
    ln Alloc.3 Tcl_Free.3
    ln Alloc.3 Tcl_Realloc.3
    ln Alloc.3 Tcl_AttemptAlloc.3
    ln Alloc.3 Tcl_AttemptRealloc.3
    ln Alloc.3 ckalloc.3
    ln Alloc.3 ckfree.3
    ln Alloc.3 ckrealloc.3
    ln Alloc.3 attemptckalloc.3
    ln Alloc.3 attemptckrealloc.3
fi
if test -r AllowExc.3; then


    rm -f Tcl_AllowExceptions.3
    ln AllowExc.3 Tcl_AllowExceptions.3
fi
if test -r AppInit.3; then


    rm -f Tcl_AppInit.3
    ln AppInit.3 Tcl_AppInit.3
fi
if test -r AssocData.3; then


    rm -f Tcl_GetAssocData.3
    rm -f Tcl_SetAssocData.3
    rm -f Tcl_DeleteAssocData.3
    ln AssocData.3 Tcl_GetAssocData.3
    ln AssocData.3 Tcl_SetAssocData.3
    ln AssocData.3 Tcl_DeleteAssocData.3
fi
if test -r Async.3; then


    rm -f Tcl_AsyncCreate.3
    rm -f Tcl_AsyncMark.3
    rm -f Tcl_AsyncInvoke.3
    rm -f Tcl_AsyncDelete.3
    rm -f Tcl_AsyncReady.3
    ln Async.3 Tcl_AsyncCreate.3
    ln Async.3 Tcl_AsyncMark.3
    ln Async.3 Tcl_AsyncInvoke.3
    ln Async.3 Tcl_AsyncDelete.3
    ln Async.3 Tcl_AsyncReady.3
fi
if test -r BackgdErr.3; then


    rm -f Tcl_BackgroundError.3
    ln BackgdErr.3 Tcl_BackgroundError.3
fi
if test -r Backslash.3; then

    rm -f Tcl_Backslash.3
    ln Backslash.3 Tcl_Backslash.3

fi
if test -r BoolObj.3; then


    rm -f Tcl_NewBooleanObj.3
    rm -f Tcl_SetBooleanObj.3
    rm -f Tcl_GetBooleanFromObj.3
    ln BoolObj.3 Tcl_NewBooleanObj.3
    ln BoolObj.3 Tcl_SetBooleanObj.3
    ln BoolObj.3 Tcl_GetBooleanFromObj.3
fi
if test -r ByteArrObj.3; then


    rm -f Tcl_NewByteArrayObj.3
    rm -f Tcl_SetByteArrayObj.3
    rm -f Tcl_GetByteArrayFromObj.3
    rm -f Tcl_SetByteArrayLength.3
    ln ByteArrObj.3 Tcl_NewByteArrayObj.3
    ln ByteArrObj.3 Tcl_SetByteArrayObj.3
    ln ByteArrObj.3 Tcl_GetByteArrayFromObj.3
    ln ByteArrObj.3 Tcl_SetByteArrayLength.3
fi
if test -r CallDel.3; then


    rm -f Tcl_CallWhenDeleted.3
    rm -f Tcl_DontCallWhenDeleted.3
    ln CallDel.3 Tcl_CallWhenDeleted.3
    ln CallDel.3 Tcl_DontCallWhenDeleted.3
fi
if test -r ChnlStack.3; then


    rm -f Tcl_StackChannel.3
    rm -f Tcl_UnstackChannel.3
    rm -f Tcl_GetStackedChannel.3
    rm -f Tcl_GetTopChannel.3
    ln ChnlStack.3 Tcl_StackChannel.3
    ln ChnlStack.3 Tcl_UnstackChannel.3
    ln ChnlStack.3 Tcl_GetStackedChannel.3
    ln ChnlStack.3 Tcl_GetTopChannel.3
fi
if test -r CmdCmplt.3; then


    rm -f Tcl_CommandComplete.3
    ln CmdCmplt.3 Tcl_CommandComplete.3
fi
if test -r Concat.3; then


    rm -f Tcl_Concat.3
    ln Concat.3 Tcl_Concat.3
fi
if test -r CrtChannel.3; then


    rm -f Tcl_CreateChannel.3
    rm -f Tcl_GetChannelInstanceData.3
    rm -f Tcl_GetChannelType.3
    rm -f Tcl_GetChannelName.3
    rm -f Tcl_GetChannelHandle.3
    rm -f Tcl_GetChannelMode.3
    rm -f Tcl_GetChannelBufferSize.3
    rm -f Tcl_SetChannelBufferSize.3
    rm -f Tcl_NotifyChannel.3
    rm -f Tcl_BadChannelOption.3
    rm -f Tcl_ChannelName.3
    rm -f Tcl_ChannelVersion.3
    rm -f Tcl_ChannelBlockModeProc.3
    rm -f Tcl_ChannelCloseProc.3
    rm -f Tcl_ChannelClose2Proc.3
    rm -f Tcl_ChannelInputProc.3
    rm -f Tcl_ChannelOutputProc.3
    rm -f Tcl_ChannelSeekProc.3
    rm -f Tcl_ChannelWideSeekProc.3
    rm -f Tcl_ChannelSetOptionProc.3
    rm -f Tcl_ChannelGetOptionProc.3
    rm -f Tcl_ChannelWatchProc.3
    rm -f Tcl_ChannelGetHandleProc.3
    rm -f Tcl_ChannelFlushProc.3
    rm -f Tcl_ChannelHandlerProc.3
    rm -f Tcl_IsChannelShared.3
    rm -f Tcl_IsChannelRegistered.3
    rm -f Tcl_CutChannel.3
    rm -f Tcl_SpliceChannel.3
    rm -f Tcl_IsChannelExisting.3
    rm -f Tcl_ClearChannelHandlers.3
    rm -f Tcl_GetChannelThread.3
    rm -f Tcl_ChannelBuffered.3
    ln CrtChannel.3 Tcl_CreateChannel.3
    ln CrtChannel.3 Tcl_GetChannelInstanceData.3
    ln CrtChannel.3 Tcl_GetChannelType.3
    ln CrtChannel.3 Tcl_GetChannelName.3
    ln CrtChannel.3 Tcl_GetChannelHandle.3
    ln CrtChannel.3 Tcl_GetChannelMode.3
    ln CrtChannel.3 Tcl_GetChannelBufferSize.3
    ln CrtChannel.3 Tcl_SetChannelBufferSize.3
    ln CrtChannel.3 Tcl_NotifyChannel.3
    ln CrtChannel.3 Tcl_BadChannelOption.3
    ln CrtChannel.3 Tcl_ChannelName.3
    ln CrtChannel.3 Tcl_ChannelVersion.3
    ln CrtChannel.3 Tcl_ChannelBlockModeProc.3
    ln CrtChannel.3 Tcl_ChannelCloseProc.3
    ln CrtChannel.3 Tcl_ChannelClose2Proc.3
    ln CrtChannel.3 Tcl_ChannelInputProc.3
    ln CrtChannel.3 Tcl_ChannelOutputProc.3
    ln CrtChannel.3 Tcl_ChannelSeekProc.3
    ln CrtChannel.3 Tcl_ChannelWideSeekProc.3
    ln CrtChannel.3 Tcl_ChannelSetOptionProc.3
    ln CrtChannel.3 Tcl_ChannelGetOptionProc.3
    ln CrtChannel.3 Tcl_ChannelWatchProc.3
    ln CrtChannel.3 Tcl_ChannelGetHandleProc.3
    ln CrtChannel.3 Tcl_ChannelFlushProc.3
    ln CrtChannel.3 Tcl_ChannelHandlerProc.3
    ln CrtChannel.3 Tcl_IsChannelShared.3
    ln CrtChannel.3 Tcl_IsChannelRegistered.3
    ln CrtChannel.3 Tcl_CutChannel.3
    ln CrtChannel.3 Tcl_SpliceChannel.3
    ln CrtChannel.3 Tcl_IsChannelExisting.3
    ln CrtChannel.3 Tcl_ClearChannelHandlers.3
    ln CrtChannel.3 Tcl_GetChannelThread.3
    ln CrtChannel.3 Tcl_ChannelBuffered.3
fi
if test -r CrtChnlHdlr.3; then


    rm -f Tcl_CreateChannelHandler.3
    rm -f Tcl_DeleteChannelHandler.3
    ln CrtChnlHdlr.3 Tcl_CreateChannelHandler.3
    ln CrtChnlHdlr.3 Tcl_DeleteChannelHandler.3
fi
if test -r CrtCloseHdlr.3; then


    rm -f Tcl_CreateCloseHandler.3
    rm -f Tcl_DeleteCloseHandler.3
    ln CrtCloseHdlr.3 Tcl_CreateCloseHandler.3
    ln CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3
fi
if test -r CrtCommand.3; then


    rm -f Tcl_CreateCommand.3
    ln CrtCommand.3 Tcl_CreateCommand.3
fi
if test -r CrtFileHdlr.3; then


    rm -f Tcl_CreateFileHandler.3
    rm -f Tcl_DeleteFileHandler.3
    ln CrtFileHdlr.3 Tcl_CreateFileHandler.3
    ln CrtFileHdlr.3 Tcl_DeleteFileHandler.3
fi
if test -r CrtInterp.3; then


    rm -f Tcl_CreateInterp.3
    rm -f Tcl_DeleteInterp.3
    rm -f Tcl_InterpDeleted.3
    ln CrtInterp.3 Tcl_CreateInterp.3
    ln CrtInterp.3 Tcl_DeleteInterp.3
    ln CrtInterp.3 Tcl_InterpDeleted.3
fi
if test -r CrtMathFnc.3; then


    rm -f Tcl_CreateMathFunc.3
    rm -f Tcl_GetMathFuncInfo.3
    rm -f Tcl_ListMathFuncs.3
    ln CrtMathFnc.3 Tcl_CreateMathFunc.3
    ln CrtMathFnc.3 Tcl_GetMathFuncInfo.3
    ln CrtMathFnc.3 Tcl_ListMathFuncs.3
fi
if test -r CrtObjCmd.3; then


    rm -f Tcl_CreateObjCommand.3
    rm -f Tcl_DeleteCommand.3
    rm -f Tcl_DeleteCommandFromToken.3
    rm -f Tcl_GetCommandInfo.3
    rm -f Tcl_GetCommandInfoFromToken.3
    rm -f Tcl_SetCommandInfo.3
    rm -f Tcl_SetCommandInfoFromToken.3
    rm -f Tcl_GetCommandName.3


    ln CrtObjCmd.3 Tcl_CreateObjCommand.3
    ln CrtObjCmd.3 Tcl_DeleteCommand.3
    ln CrtObjCmd.3 Tcl_DeleteCommandFromToken.3
    ln CrtObjCmd.3 Tcl_GetCommandInfo.3
    ln CrtObjCmd.3 Tcl_GetCommandInfoFromToken.3
    ln CrtObjCmd.3 Tcl_SetCommandInfo.3
    ln CrtObjCmd.3 Tcl_SetCommandInfoFromToken.3
    ln CrtObjCmd.3 Tcl_GetCommandName.3


fi
if test -r CrtSlave.3; then


    rm -f Tcl_IsSafe.3
    rm -f Tcl_MakeSafe.3
    rm -f Tcl_CreateSlave.3
    rm -f Tcl_GetSlave.3
    rm -f Tcl_GetMaster.3
    rm -f Tcl_GetInterpPath.3
    rm -f Tcl_CreateAlias.3
    rm -f Tcl_CreateAliasObj.3
    rm -f Tcl_GetAlias.3
    rm -f Tcl_GetAliasObj.3
    rm -f Tcl_ExposeCommand.3
    rm -f Tcl_HideCommand.3
    ln CrtSlave.3 Tcl_IsSafe.3
    ln CrtSlave.3 Tcl_MakeSafe.3
    ln CrtSlave.3 Tcl_CreateSlave.3
    ln CrtSlave.3 Tcl_GetSlave.3
    ln CrtSlave.3 Tcl_GetMaster.3
    ln CrtSlave.3 Tcl_GetInterpPath.3
    ln CrtSlave.3 Tcl_CreateAlias.3
    ln CrtSlave.3 Tcl_CreateAliasObj.3
    ln CrtSlave.3 Tcl_GetAlias.3
    ln CrtSlave.3 Tcl_GetAliasObj.3
    ln CrtSlave.3 Tcl_ExposeCommand.3
    ln CrtSlave.3 Tcl_HideCommand.3
fi
if test -r CrtTimerHdlr.3; then


    rm -f Tcl_CreateTimerHandler.3
    rm -f Tcl_DeleteTimerHandler.3
    ln CrtTimerHdlr.3 Tcl_CreateTimerHandler.3
    ln CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3
fi
if test -r CrtTrace.3; then


    rm -f Tcl_CreateTrace.3
    rm -f Tcl_CreateObjTrace.3
    rm -f Tcl_DeleteTrace.3
    ln CrtTrace.3 Tcl_CreateTrace.3
    ln CrtTrace.3 Tcl_CreateObjTrace.3
    ln CrtTrace.3 Tcl_DeleteTrace.3
fi
if test -r DString.3; then


    rm -f Tcl_DStringInit.3
    rm -f Tcl_DStringAppend.3
    rm -f Tcl_DStringAppendElement.3
    rm -f Tcl_DStringStartSublist.3
    rm -f Tcl_DStringEndSublist.3
    rm -f Tcl_DStringLength.3
    rm -f Tcl_DStringValue.3
    rm -f Tcl_DStringSetLength.3
    rm -f Tcl_DStringTrunc.3
    rm -f Tcl_DStringFree.3
    rm -f Tcl_DStringResult.3
    rm -f Tcl_DStringGetResult.3
    ln DString.3 Tcl_DStringInit.3
    ln DString.3 Tcl_DStringAppend.3
    ln DString.3 Tcl_DStringAppendElement.3
    ln DString.3 Tcl_DStringStartSublist.3
    ln DString.3 Tcl_DStringEndSublist.3
    ln DString.3 Tcl_DStringLength.3
    ln DString.3 Tcl_DStringValue.3
    ln DString.3 Tcl_DStringSetLength.3
    ln DString.3 Tcl_DStringTrunc.3
    ln DString.3 Tcl_DStringFree.3
    ln DString.3 Tcl_DStringResult.3
    ln DString.3 Tcl_DStringGetResult.3
fi
if test -r DetachPids.3; then


    rm -f Tcl_DetachPids.3
    rm -f Tcl_ReapDetachedProcs.3
    rm -f Tcl_WaitPid.3
    ln DetachPids.3 Tcl_DetachPids.3
    ln DetachPids.3 Tcl_ReapDetachedProcs.3
    ln DetachPids.3 Tcl_WaitPid.3
fi
if test -r DoOneEvent.3; then

    rm -f Tcl_DoOneEvent.3
    ln DoOneEvent.3 Tcl_DoOneEvent.3

fi
if test -r DoWhenIdle.3; then


    rm -f Tcl_DoWhenIdle.3
    rm -f Tcl_CancelIdleCall.3
    ln DoWhenIdle.3 Tcl_DoWhenIdle.3
    ln DoWhenIdle.3 Tcl_CancelIdleCall.3
fi
if test -r DoubleObj.3; then


    rm -f Tcl_NewDoubleObj.3
    rm -f Tcl_SetDoubleObj.3
    rm -f Tcl_GetDoubleFromObj.3
    ln DoubleObj.3 Tcl_NewDoubleObj.3
    ln DoubleObj.3 Tcl_SetDoubleObj.3
    ln DoubleObj.3 Tcl_GetDoubleFromObj.3
fi
if test -r DumpActiveMemory.3; then


    rm -f Tcl_DumpActiveMemory.3
    rm -f Tcl_InitMemory.3
    rm -f Tcl_ValidateAllMemory.3
    ln DumpActiveMemory.3 Tcl_DumpActiveMemory.3
    ln DumpActiveMemory.3 Tcl_InitMemory.3
    ln DumpActiveMemory.3 Tcl_ValidateAllMemory.3
fi
if test -r Encoding.3; then


    rm -f Tcl_GetEncoding.3
    rm -f Tcl_FreeEncoding.3
    rm -f Tcl_ExternalToUtfDString.3
    rm -f Tcl_ExternalToUtf.3
    rm -f Tcl_UtfToExternalDString.3
    rm -f Tcl_UtfToExternal.3
    rm -f Tcl_WinTCharToUtf.3
    rm -f Tcl_WinUtfToTChar.3
    rm -f Tcl_GetEncodingName.3
    rm -f Tcl_SetSystemEncoding.3
    rm -f Tcl_GetEncodingNames.3
    rm -f Tcl_CreateEncoding.3
    rm -f Tcl_GetDefaultEncodingDir.3
    rm -f Tcl_SetDefaultEncodingDir.3
    ln Encoding.3 Tcl_GetEncoding.3
    ln Encoding.3 Tcl_FreeEncoding.3
    ln Encoding.3 Tcl_ExternalToUtfDString.3
    ln Encoding.3 Tcl_ExternalToUtf.3
    ln Encoding.3 Tcl_UtfToExternalDString.3
    ln Encoding.3 Tcl_UtfToExternal.3
    ln Encoding.3 Tcl_WinTCharToUtf.3
    ln Encoding.3 Tcl_WinUtfToTChar.3
    ln Encoding.3 Tcl_GetEncodingName.3
    ln Encoding.3 Tcl_SetSystemEncoding.3
    ln Encoding.3 Tcl_GetEncodingNames.3
    ln Encoding.3 Tcl_CreateEncoding.3
    ln Encoding.3 Tcl_GetDefaultEncodingDir.3
    ln Encoding.3 Tcl_SetDefaultEncodingDir.3
fi
if test -r Environment.3; then


    rm -f Tcl_PutEnv.3
    ln Environment.3 Tcl_PutEnv.3
fi
if test -r Eval.3; then


    rm -f Tcl_EvalObjEx.3
    rm -f Tcl_EvalFile.3
    rm -f Tcl_EvalObjv.3
    rm -f Tcl_Eval.3
    rm -f Tcl_EvalEx.3
    rm -f Tcl_GlobalEval.3
    rm -f Tcl_GlobalEvalObj.3
    rm -f Tcl_VarEval.3
    rm -f Tcl_VarEvalVA.3
    ln Eval.3 Tcl_EvalObjEx.3
    ln Eval.3 Tcl_EvalFile.3
    ln Eval.3 Tcl_EvalObjv.3
    ln Eval.3 Tcl_Eval.3
    ln Eval.3 Tcl_EvalEx.3
    ln Eval.3 Tcl_GlobalEval.3
    ln Eval.3 Tcl_GlobalEvalObj.3
    ln Eval.3 Tcl_VarEval.3
    ln Eval.3 Tcl_VarEvalVA.3
fi
if test -r Exit.3; then


    rm -f Tcl_Exit.3
    rm -f Tcl_Finalize.3
    rm -f Tcl_CreateExitHandler.3
    rm -f Tcl_DeleteExitHandler.3
    rm -f Tcl_ExitThread.3
    rm -f Tcl_FinalizeThread.3
    rm -f Tcl_CreateThreadExitHandler.3
    rm -f Tcl_DeleteThreadExitHandler.3
    ln Exit.3 Tcl_Exit.3
    ln Exit.3 Tcl_Finalize.3
    ln Exit.3 Tcl_CreateExitHandler.3
    ln Exit.3 Tcl_DeleteExitHandler.3
    ln Exit.3 Tcl_ExitThread.3
    ln Exit.3 Tcl_FinalizeThread.3
    ln Exit.3 Tcl_CreateThreadExitHandler.3
    ln Exit.3 Tcl_DeleteThreadExitHandler.3
fi
if test -r ExprLong.3; then


    rm -f Tcl_ExprLong.3
    rm -f Tcl_ExprDouble.3
    rm -f Tcl_ExprBoolean.3
    rm -f Tcl_ExprString.3
    ln ExprLong.3 Tcl_ExprLong.3
    ln ExprLong.3 Tcl_ExprDouble.3
    ln ExprLong.3 Tcl_ExprBoolean.3
    ln ExprLong.3 Tcl_ExprString.3
fi
if test -r ExprLongObj.3; then


    rm -f Tcl_ExprLongObj.3
    rm -f Tcl_ExprDoubleObj.3
    rm -f Tcl_ExprBooleanObj.3
    rm -f Tcl_ExprObj.3
    ln ExprLongObj.3 Tcl_ExprLongObj.3
    ln ExprLongObj.3 Tcl_ExprDoubleObj.3
    ln ExprLongObj.3 Tcl_ExprBooleanObj.3
    ln ExprLongObj.3 Tcl_ExprObj.3
fi
if test -r FileSystem.3; then


    rm -f Tcl_FSRegister.3
    rm -f Tcl_FSUnregister.3
    rm -f Tcl_FSData.3
    rm -f Tcl_FSMountsChanged.3
    rm -f Tcl_FSGetFileSystemForPath.3
    rm -f Tcl_FSGetPathType.3
    rm -f Tcl_FSCopyFile.3
    rm -f Tcl_FSCopyDirectory.3
    rm -f Tcl_FSCreateDirectory.3
    rm -f Tcl_FSDeleteFile.3
    rm -f Tcl_FSRemoveDirectory.3
    rm -f Tcl_FSRenameFile.3
    rm -f Tcl_FSListVolumes.3
    rm -f Tcl_FSEvalFile.3
    rm -f Tcl_FSLoadFile.3
    rm -f Tcl_FSMatchInDirectory.3
    rm -f Tcl_FSLink.3
    rm -f Tcl_FSLstat.3
    rm -f Tcl_FSUtime.3
    rm -f Tcl_FSFileAttrsGet.3
    rm -f Tcl_FSFileAttrsSet.3
    rm -f Tcl_FSFileAttrStrings.3
    rm -f Tcl_FSStat.3
    rm -f Tcl_FSAccess.3
    rm -f Tcl_FSOpenFileChannel.3
    rm -f Tcl_FSGetCwd.3
    rm -f Tcl_FSChdir.3
    rm -f Tcl_FSPathSeparator.3
    rm -f Tcl_FSJoinPath.3
    rm -f Tcl_FSSplitPath.3
    rm -f Tcl_FSEqualPaths.3
    rm -f Tcl_FSGetNormalizedPath.3
    rm -f Tcl_FSJoinToPath.3
    rm -f Tcl_FSConvertToPathType.3
    rm -f Tcl_FSGetInternalRep.3
    rm -f Tcl_FSGetTranslatedPath.3
    rm -f Tcl_FSGetTranslatedStringPath.3
    rm -f Tcl_FSNewNativePath.3
    rm -f Tcl_FSGetNativePath.3
    rm -f Tcl_FSFileSystemInfo.3
    rm -f Tcl_AllocStatBuf.3
    ln FileSystem.3 Tcl_FSRegister.3
    ln FileSystem.3 Tcl_FSUnregister.3
    ln FileSystem.3 Tcl_FSData.3
    ln FileSystem.3 Tcl_FSMountsChanged.3
    ln FileSystem.3 Tcl_FSGetFileSystemForPath.3
    ln FileSystem.3 Tcl_FSGetPathType.3
    ln FileSystem.3 Tcl_FSCopyFile.3
    ln FileSystem.3 Tcl_FSCopyDirectory.3
    ln FileSystem.3 Tcl_FSCreateDirectory.3
    ln FileSystem.3 Tcl_FSDeleteFile.3
    ln FileSystem.3 Tcl_FSRemoveDirectory.3
    ln FileSystem.3 Tcl_FSRenameFile.3
    ln FileSystem.3 Tcl_FSListVolumes.3
    ln FileSystem.3 Tcl_FSEvalFile.3
    ln FileSystem.3 Tcl_FSLoadFile.3
    ln FileSystem.3 Tcl_FSMatchInDirectory.3
    ln FileSystem.3 Tcl_FSLink.3
    ln FileSystem.3 Tcl_FSLstat.3
    ln FileSystem.3 Tcl_FSUtime.3
    ln FileSystem.3 Tcl_FSFileAttrsGet.3
    ln FileSystem.3 Tcl_FSFileAttrsSet.3
    ln FileSystem.3 Tcl_FSFileAttrStrings.3
    ln FileSystem.3 Tcl_FSStat.3
    ln FileSystem.3 Tcl_FSAccess.3
    ln FileSystem.3 Tcl_FSOpenFileChannel.3
    ln FileSystem.3 Tcl_FSGetCwd.3
    ln FileSystem.3 Tcl_FSChdir.3
    ln FileSystem.3 Tcl_FSPathSeparator.3
    ln FileSystem.3 Tcl_FSJoinPath.3
    ln FileSystem.3 Tcl_FSSplitPath.3
    ln FileSystem.3 Tcl_FSEqualPaths.3
    ln FileSystem.3 Tcl_FSGetNormalizedPath.3
    ln FileSystem.3 Tcl_FSJoinToPath.3
    ln FileSystem.3 Tcl_FSConvertToPathType.3
    ln FileSystem.3 Tcl_FSGetInternalRep.3
    ln FileSystem.3 Tcl_FSGetTranslatedPath.3
    ln FileSystem.3 Tcl_FSGetTranslatedStringPath.3
    ln FileSystem.3 Tcl_FSNewNativePath.3
    ln FileSystem.3 Tcl_FSGetNativePath.3
    ln FileSystem.3 Tcl_FSFileSystemInfo.3
    ln FileSystem.3 Tcl_AllocStatBuf.3
fi
if test -r FindExec.3; then


    rm -f Tcl_FindExecutable.3
    rm -f Tcl_GetNameOfExecutable.3
    ln FindExec.3 Tcl_FindExecutable.3
    ln FindExec.3 Tcl_GetNameOfExecutable.3
fi
if test -r GetCwd.3; then


    rm -f Tcl_GetCwd.3
    rm -f Tcl_Chdir.3
    ln GetCwd.3 Tcl_GetCwd.3
    ln GetCwd.3 Tcl_Chdir.3
fi
if test -r GetHostName.3; then

    rm -f Tcl_GetHostName.3
    ln GetHostName.3 Tcl_GetHostName.3

fi
if test -r GetIndex.3; then


    rm -f Tcl_GetIndexFromObj.3
    rm -f Tcl_GetIndexFromObjStruct.3
    ln GetIndex.3 Tcl_GetIndexFromObj.3
    ln GetIndex.3 Tcl_GetIndexFromObjStruct.3
fi
if test -r GetInt.3; then


    rm -f Tcl_GetInt.3
    rm -f Tcl_GetDouble.3
    rm -f Tcl_GetBoolean.3
    ln GetInt.3 Tcl_GetInt.3
    ln GetInt.3 Tcl_GetDouble.3
    ln GetInt.3 Tcl_GetBoolean.3
fi
if test -r GetOpnFl.3; then


    rm -f Tcl_GetOpenFile.3
    ln GetOpnFl.3 Tcl_GetOpenFile.3
fi
if test -r GetStdChan.3; then


    rm -f Tcl_GetStdChannel.3
    rm -f Tcl_SetStdChannel.3
    ln GetStdChan.3 Tcl_GetStdChannel.3
    ln GetStdChan.3 Tcl_SetStdChannel.3
fi
if test -r GetTime.3; then


    rm -f Tcl_GetTime.3
    ln GetTime.3 Tcl_GetTime.3
fi
if test -r GetVersion.3; then

    rm -f Tcl_GetVersion.3
    ln GetVersion.3 Tcl_GetVersion.3

fi
if test -r Hash.3; then


    rm -f Tcl_InitHashTable.3
    rm -f Tcl_InitCustomHashTable.3
    rm -f Tcl_InitObjHashTable.3
    rm -f Tcl_DeleteHashTable.3
    rm -f Tcl_CreateHashEntry.3
    rm -f Tcl_DeleteHashEntry.3
    rm -f Tcl_FindHashEntry.3
    rm -f Tcl_GetHashValue.3
    rm -f Tcl_SetHashValue.3
    rm -f Tcl_GetHashKey.3
    rm -f Tcl_FirstHashEntry.3
    rm -f Tcl_NextHashEntry.3
    rm -f Tcl_HashStats.3
    ln Hash.3 Tcl_InitHashTable.3
    ln Hash.3 Tcl_InitCustomHashTable.3
    ln Hash.3 Tcl_InitObjHashTable.3
    ln Hash.3 Tcl_DeleteHashTable.3
    ln Hash.3 Tcl_CreateHashEntry.3
    ln Hash.3 Tcl_DeleteHashEntry.3
    ln Hash.3 Tcl_FindHashEntry.3
    ln Hash.3 Tcl_GetHashValue.3
    ln Hash.3 Tcl_SetHashValue.3
    ln Hash.3 Tcl_GetHashKey.3
    ln Hash.3 Tcl_FirstHashEntry.3
    ln Hash.3 Tcl_NextHashEntry.3
    ln Hash.3 Tcl_HashStats.3
fi
if test -r Init.3; then


    rm -f Tcl_Init.3
    ln Init.3 Tcl_Init.3
fi
if test -r InitStubs.3; then

    rm -f Tcl_InitStubs.3
    ln InitStubs.3 Tcl_InitStubs.3

fi
if test -r IntObj.3; then


    rm -f Tcl_NewIntObj.3
    rm -f Tcl_NewLongObj.3
    rm -f Tcl_NewWideIntObj.3
    rm -f Tcl_SetIntObj.3
    rm -f Tcl_SetLongObj.3
    rm -f Tcl_SetWideIntObj.3
    rm -f Tcl_GetIntFromObj.3
    rm -f Tcl_GetLongFromObj.3
    rm -f Tcl_GetWideIntFromObj.3
    ln IntObj.3 Tcl_NewIntObj.3
    ln IntObj.3 Tcl_NewLongObj.3
    ln IntObj.3 Tcl_NewWideIntObj.3
    ln IntObj.3 Tcl_SetIntObj.3
    ln IntObj.3 Tcl_SetLongObj.3
    ln IntObj.3 Tcl_SetWideIntObj.3
    ln IntObj.3 Tcl_GetIntFromObj.3
    ln IntObj.3 Tcl_GetLongFromObj.3
    ln IntObj.3 Tcl_GetWideIntFromObj.3
fi
if test -r Interp.3; then


    rm -f Tcl_Interp.3
    ln Interp.3 Tcl_Interp.3
fi
if test -r LinkVar.3; then


    rm -f Tcl_LinkVar.3
    rm -f Tcl_UnlinkVar.3
    rm -f Tcl_UpdateLinkedVar.3
    ln LinkVar.3 Tcl_LinkVar.3
    ln LinkVar.3 Tcl_UnlinkVar.3
    ln LinkVar.3 Tcl_UpdateLinkedVar.3
fi
if test -r ListObj.3; then


    rm -f Tcl_ListObjAppendList.3
    rm -f Tcl_ListObjAppendElement.3
    rm -f Tcl_NewListObj.3
    rm -f Tcl_SetListObj.3
    rm -f Tcl_ListObjGetElements.3
    rm -f Tcl_ListObjLength.3
    rm -f Tcl_ListObjIndex.3
    rm -f Tcl_ListObjReplace.3
    ln ListObj.3 Tcl_ListObjAppendList.3
    ln ListObj.3 Tcl_ListObjAppendElement.3
    ln ListObj.3 Tcl_NewListObj.3
    ln ListObj.3 Tcl_SetListObj.3
    ln ListObj.3 Tcl_ListObjGetElements.3
    ln ListObj.3 Tcl_ListObjLength.3
    ln ListObj.3 Tcl_ListObjIndex.3
    ln ListObj.3 Tcl_ListObjReplace.3
fi
if test -r Macintosh.3; then


    rm -f Tcl_MacSetEventProc.3
    rm -f Tcl_MacConvertTextResource.3
    rm -f Tcl_MacEvalResource.3
    rm -f Tcl_MacFindResource.3
    rm -f Tcl_GetOSTypeFromObj.3
    rm -f Tcl_SetOSTypeObj.3
    rm -f Tcl_NewOSTypeObj.3
    ln Macintosh.3 Tcl_MacSetEventProc.3
    ln Macintosh.3 Tcl_MacConvertTextResource.3
    ln Macintosh.3 Tcl_MacEvalResource.3
    ln Macintosh.3 Tcl_MacFindResource.3
    ln Macintosh.3 Tcl_GetOSTypeFromObj.3
    ln Macintosh.3 Tcl_SetOSTypeObj.3
    ln Macintosh.3 Tcl_NewOSTypeObj.3
fi
if test -r Notifier.3; then


    rm -f Tcl_CreateEventSource.3
    rm -f Tcl_DeleteEventSource.3
    rm -f Tcl_SetMaxBlockTime.3
    rm -f Tcl_QueueEvent.3
    rm -f Tcl_ThreadQueueEvent.3
    rm -f Tcl_ThreadAlert.3
    rm -f Tcl_GetCurrentThread.3
    rm -f Tcl_DeleteEvents.3
    rm -f Tcl_InitNotifier.3
    rm -f Tcl_FinalizeNotifier.3
    rm -f Tcl_WaitForEvent.3
    rm -f Tcl_AlertNotifier.3
    rm -f Tcl_SetTimer.3
    rm -f Tcl_ServiceAll.3
    rm -f Tcl_ServiceEvent.3
    rm -f Tcl_GetServiceMode.3
    rm -f Tcl_SetServiceMode.3
    ln Notifier.3 Tcl_CreateEventSource.3
    ln Notifier.3 Tcl_DeleteEventSource.3
    ln Notifier.3 Tcl_SetMaxBlockTime.3
    ln Notifier.3 Tcl_QueueEvent.3
    ln Notifier.3 Tcl_ThreadQueueEvent.3
    ln Notifier.3 Tcl_ThreadAlert.3
    ln Notifier.3 Tcl_GetCurrentThread.3
    ln Notifier.3 Tcl_DeleteEvents.3
    ln Notifier.3 Tcl_InitNotifier.3
    ln Notifier.3 Tcl_FinalizeNotifier.3
    ln Notifier.3 Tcl_WaitForEvent.3
    ln Notifier.3 Tcl_AlertNotifier.3
    ln Notifier.3 Tcl_SetTimer.3
    ln Notifier.3 Tcl_ServiceAll.3
    ln Notifier.3 Tcl_ServiceEvent.3
    ln Notifier.3 Tcl_GetServiceMode.3
    ln Notifier.3 Tcl_SetServiceMode.3
fi
if test -r Object.3; then


    rm -f Tcl_NewObj.3
    rm -f Tcl_DuplicateObj.3
    rm -f Tcl_IncrRefCount.3
    rm -f Tcl_DecrRefCount.3
    rm -f Tcl_IsShared.3
    rm -f Tcl_InvalidateStringRep.3
    ln Object.3 Tcl_NewObj.3
    ln Object.3 Tcl_DuplicateObj.3
    ln Object.3 Tcl_IncrRefCount.3
    ln Object.3 Tcl_DecrRefCount.3
    ln Object.3 Tcl_IsShared.3
    ln Object.3 Tcl_InvalidateStringRep.3
fi
if test -r ObjectType.3; then


    rm -f Tcl_RegisterObjType.3
    rm -f Tcl_GetObjType.3
    rm -f Tcl_AppendAllObjTypes.3
    rm -f Tcl_ConvertToType.3
    ln ObjectType.3 Tcl_RegisterObjType.3
    ln ObjectType.3 Tcl_GetObjType.3
    ln ObjectType.3 Tcl_AppendAllObjTypes.3
    ln ObjectType.3 Tcl_ConvertToType.3
fi
if test -r OpenFileChnl.3; then


    rm -f Tcl_OpenFileChannel.3
    rm -f Tcl_OpenCommandChannel.3
    rm -f Tcl_MakeFileChannel.3
    rm -f Tcl_GetChannel.3
    rm -f Tcl_GetChannelNames.3
    rm -f Tcl_GetChannelNamesEx.3
    rm -f Tcl_RegisterChannel.3
    rm -f Tcl_UnregisterChannel.3
    rm -f Tcl_DetachChannel.3
    rm -f Tcl_IsStandardChannel.3
    rm -f Tcl_Close.3
    rm -f Tcl_ReadChars.3
    rm -f Tcl_Read.3
    rm -f Tcl_GetsObj.3
    rm -f Tcl_Gets.3
    rm -f Tcl_WriteObj.3
    rm -f Tcl_WriteChars.3
    rm -f Tcl_Write.3
    rm -f Tcl_Flush.3
    rm -f Tcl_Seek.3
    rm -f Tcl_Tell.3
    rm -f Tcl_GetChannelOption.3
    rm -f Tcl_SetChannelOption.3
    rm -f Tcl_Eof.3
    rm -f Tcl_InputBlocked.3
    rm -f Tcl_InputBuffered.3
    rm -f Tcl_OutputBuffered.3
    rm -f Tcl_Ungets.3
    rm -f Tcl_ReadRaw.3
    rm -f Tcl_WriteRaw.3
    ln OpenFileChnl.3 Tcl_OpenFileChannel.3
    ln OpenFileChnl.3 Tcl_OpenCommandChannel.3
    ln OpenFileChnl.3 Tcl_MakeFileChannel.3
    ln OpenFileChnl.3 Tcl_GetChannel.3
    ln OpenFileChnl.3 Tcl_GetChannelNames.3
    ln OpenFileChnl.3 Tcl_GetChannelNamesEx.3
    ln OpenFileChnl.3 Tcl_RegisterChannel.3
    ln OpenFileChnl.3 Tcl_UnregisterChannel.3
    ln OpenFileChnl.3 Tcl_DetachChannel.3
    ln OpenFileChnl.3 Tcl_IsStandardChannel.3
    ln OpenFileChnl.3 Tcl_Close.3
    ln OpenFileChnl.3 Tcl_ReadChars.3
    ln OpenFileChnl.3 Tcl_Read.3
    ln OpenFileChnl.3 Tcl_GetsObj.3
    ln OpenFileChnl.3 Tcl_Gets.3
    ln OpenFileChnl.3 Tcl_WriteObj.3
    ln OpenFileChnl.3 Tcl_WriteChars.3
    ln OpenFileChnl.3 Tcl_Write.3
    ln OpenFileChnl.3 Tcl_Flush.3
    ln OpenFileChnl.3 Tcl_Seek.3
    ln OpenFileChnl.3 Tcl_Tell.3
    ln OpenFileChnl.3 Tcl_GetChannelOption.3
    ln OpenFileChnl.3 Tcl_SetChannelOption.3
    ln OpenFileChnl.3 Tcl_Eof.3
    ln OpenFileChnl.3 Tcl_InputBlocked.3
    ln OpenFileChnl.3 Tcl_InputBuffered.3
    ln OpenFileChnl.3 Tcl_OutputBuffered.3
    ln OpenFileChnl.3 Tcl_Ungets.3
    ln OpenFileChnl.3 Tcl_ReadRaw.3
    ln OpenFileChnl.3 Tcl_WriteRaw.3
fi
if test -r OpenTcp.3; then


    rm -f Tcl_OpenTcpClient.3
    rm -f Tcl_MakeTcpClientChannel.3
    rm -f Tcl_OpenTcpServer.3
    ln OpenTcp.3 Tcl_OpenTcpClient.3
    ln OpenTcp.3 Tcl_MakeTcpClientChannel.3
    ln OpenTcp.3 Tcl_OpenTcpServer.3
fi
if test -r Panic.3; then


    rm -f Tcl_Panic.3
    rm -f Tcl_PanicVA.3
    rm -f Tcl_SetPanicProc.3
    if test "${CASEINSENSITIVEFS:-}" != "1"; then rm -f panic.3; fi
    rm -f panicVA.3
    ln Panic.3 Tcl_Panic.3
    ln Panic.3 Tcl_PanicVA.3
    ln Panic.3 Tcl_SetPanicProc.3
    if test "${CASEINSENSITIVEFS:-}" != "1"; then ln Panic.3 panic.3; fi
    ln Panic.3 panicVA.3
fi
if test -r ParseCmd.3; then


    rm -f Tcl_ParseCommand.3
    rm -f Tcl_ParseExpr.3
    rm -f Tcl_ParseBraces.3
    rm -f Tcl_ParseQuotedString.3
    rm -f Tcl_ParseVarName.3
    rm -f Tcl_ParseVar.3
    rm -f Tcl_FreeParse.3
    rm -f Tcl_EvalTokens.3
    rm -f Tcl_EvalTokensStandard.3
    ln ParseCmd.3 Tcl_ParseCommand.3
    ln ParseCmd.3 Tcl_ParseExpr.3
    ln ParseCmd.3 Tcl_ParseBraces.3
    ln ParseCmd.3 Tcl_ParseQuotedString.3
    ln ParseCmd.3 Tcl_ParseVarName.3
    ln ParseCmd.3 Tcl_ParseVar.3
    ln ParseCmd.3 Tcl_FreeParse.3
    ln ParseCmd.3 Tcl_EvalTokens.3
    ln ParseCmd.3 Tcl_EvalTokensStandard.3
fi
if test -r PkgRequire.3; then


    rm -f Tcl_PkgRequire.3
    rm -f Tcl_PkgRequireEx.3
    rm -f Tcl_PkgPresent.3
    rm -f Tcl_PkgPresentEx.3
    rm -f Tcl_PkgProvide.3
    rm -f Tcl_PkgProvideEx.3
    ln PkgRequire.3 Tcl_PkgRequire.3
    ln PkgRequire.3 Tcl_PkgRequireEx.3
    ln PkgRequire.3 Tcl_PkgPresent.3
    ln PkgRequire.3 Tcl_PkgPresentEx.3
    ln PkgRequire.3 Tcl_PkgProvide.3
    ln PkgRequire.3 Tcl_PkgProvideEx.3
fi
if test -r Preserve.3; then


    rm -f Tcl_Preserve.3
    rm -f Tcl_Release.3
    rm -f Tcl_EventuallyFree.3
    ln Preserve.3 Tcl_Preserve.3
    ln Preserve.3 Tcl_Release.3
    ln Preserve.3 Tcl_EventuallyFree.3
fi
if test -r PrintDbl.3; then


    rm -f Tcl_PrintDouble.3
    ln PrintDbl.3 Tcl_PrintDouble.3
fi
if test -r RecEvalObj.3; then


    rm -f Tcl_RecordAndEvalObj.3
    ln RecEvalObj.3 Tcl_RecordAndEvalObj.3
fi
if test -r RecordEval.3; then


    rm -f Tcl_RecordAndEval.3
    ln RecordEval.3 Tcl_RecordAndEval.3
fi
if test -r RegExp.3; then


    rm -f Tcl_RegExpMatch.3
    rm -f Tcl_RegExpCompile.3
    rm -f Tcl_RegExpExec.3
    rm -f Tcl_RegExpRange.3
    rm -f Tcl_GetRegExpFromObj.3
    rm -f Tcl_RegExpMatchObj.3
    rm -f Tcl_RegExpExecObj.3
    rm -f Tcl_RegExpGetInfo.3
    ln RegExp.3 Tcl_RegExpMatch.3
    ln RegExp.3 Tcl_RegExpCompile.3
    ln RegExp.3 Tcl_RegExpExec.3
    ln RegExp.3 Tcl_RegExpRange.3
    ln RegExp.3 Tcl_GetRegExpFromObj.3
    ln RegExp.3 Tcl_RegExpMatchObj.3
    ln RegExp.3 Tcl_RegExpExecObj.3
    ln RegExp.3 Tcl_RegExpGetInfo.3
fi
if test -r SaveResult.3; then


    rm -f Tcl_SaveResult.3
    rm -f Tcl_RestoreResult.3
    rm -f Tcl_DiscardResult.3
    ln SaveResult.3 Tcl_SaveResult.3
    ln SaveResult.3 Tcl_RestoreResult.3
    ln SaveResult.3 Tcl_DiscardResult.3
fi
if test -r SetErrno.3; then


    rm -f Tcl_SetErrno.3
    rm -f Tcl_GetErrno.3
    rm -f Tcl_ErrnoId.3
    rm -f Tcl_ErrnoMsg.3
    ln SetErrno.3 Tcl_SetErrno.3
    ln SetErrno.3 Tcl_GetErrno.3
    ln SetErrno.3 Tcl_ErrnoId.3
    ln SetErrno.3 Tcl_ErrnoMsg.3
fi
if test -r SetRecLmt.3; then


    rm -f Tcl_SetRecursionLimit.3
    ln SetRecLmt.3 Tcl_SetRecursionLimit.3
fi
if test -r SetResult.3; then


    rm -f Tcl_SetObjResult.3
    rm -f Tcl_GetObjResult.3
    rm -f Tcl_SetResult.3
    rm -f Tcl_GetStringResult.3
    rm -f Tcl_AppendResult.3
    rm -f Tcl_AppendResultVA.3
    rm -f Tcl_AppendElement.3
    rm -f Tcl_ResetResult.3
    rm -f Tcl_FreeResult.3
    ln SetResult.3 Tcl_SetObjResult.3
    ln SetResult.3 Tcl_GetObjResult.3
    ln SetResult.3 Tcl_SetResult.3
    ln SetResult.3 Tcl_GetStringResult.3
    ln SetResult.3 Tcl_AppendResult.3
    ln SetResult.3 Tcl_AppendResultVA.3
    ln SetResult.3 Tcl_AppendElement.3
    ln SetResult.3 Tcl_ResetResult.3
    ln SetResult.3 Tcl_FreeResult.3
fi
if test -r SetVar.3; then


    rm -f Tcl_SetVar2Ex.3
    rm -f Tcl_SetVar.3
    rm -f Tcl_SetVar2.3
    rm -f Tcl_ObjSetVar2.3
    rm -f Tcl_GetVar2Ex.3
    rm -f Tcl_GetVar.3
    rm -f Tcl_GetVar2.3
    rm -f Tcl_ObjGetVar2.3
    rm -f Tcl_UnsetVar.3
    rm -f Tcl_UnsetVar2.3
    ln SetVar.3 Tcl_SetVar2Ex.3
    ln SetVar.3 Tcl_SetVar.3
    ln SetVar.3 Tcl_SetVar2.3
    ln SetVar.3 Tcl_ObjSetVar2.3
    ln SetVar.3 Tcl_GetVar2Ex.3
    ln SetVar.3 Tcl_GetVar.3
    ln SetVar.3 Tcl_GetVar2.3
    ln SetVar.3 Tcl_ObjGetVar2.3
    ln SetVar.3 Tcl_UnsetVar.3
    ln SetVar.3 Tcl_UnsetVar2.3
fi
if test -r Signal.3; then


    rm -f Tcl_SignalId.3
    rm -f Tcl_SignalMsg.3
    ln Signal.3 Tcl_SignalId.3
    ln Signal.3 Tcl_SignalMsg.3
fi
if test -r Sleep.3; then


    rm -f Tcl_Sleep.3
    ln Sleep.3 Tcl_Sleep.3
fi
if test -r SourceRCFile.3; then

    rm -f Tcl_SourceRCFile.3
    ln SourceRCFile.3 Tcl_SourceRCFile.3

fi
if test -r SplitList.3; then


    rm -f Tcl_SplitList.3
    rm -f Tcl_Merge.3
    rm -f Tcl_ScanElement.3
    rm -f Tcl_ConvertElement.3
    rm -f Tcl_ScanCountedElement.3
    rm -f Tcl_ConvertCountedElement.3
    ln SplitList.3 Tcl_SplitList.3
    ln SplitList.3 Tcl_Merge.3
    ln SplitList.3 Tcl_ScanElement.3
    ln SplitList.3 Tcl_ConvertElement.3
    ln SplitList.3 Tcl_ScanCountedElement.3
    ln SplitList.3 Tcl_ConvertCountedElement.3
fi
if test -r SplitPath.3; then


    rm -f Tcl_SplitPath.3
    rm -f Tcl_JoinPath.3
    rm -f Tcl_GetPathType.3
    ln SplitPath.3 Tcl_SplitPath.3
    ln SplitPath.3 Tcl_JoinPath.3
    ln SplitPath.3 Tcl_GetPathType.3
fi
if test -r StaticPkg.3; then


    rm -f Tcl_StaticPackage.3
    ln StaticPkg.3 Tcl_StaticPackage.3
fi
if test -r StdChannels.3; then


    rm -f Tcl_StandardChannels.3
    ln StdChannels.3 Tcl_StandardChannels.3
fi
if test -r StrMatch.3; then


    rm -f Tcl_StringMatch.3
    rm -f Tcl_StringCaseMatch.3
    ln StrMatch.3 Tcl_StringMatch.3
    ln StrMatch.3 Tcl_StringCaseMatch.3
fi
if test -r StringObj.3; then


    rm -f Tcl_NewStringObj.3
    rm -f Tcl_NewUnicodeObj.3
    rm -f Tcl_SetStringObj.3
    rm -f Tcl_SetUnicodeObj.3
    rm -f Tcl_GetStringFromObj.3
    rm -f Tcl_GetString.3
    rm -f Tcl_GetUnicodeFromObj.3
    rm -f Tcl_GetUnicode.3
    rm -f Tcl_GetUniChar.3
    rm -f Tcl_GetCharLength.3
    rm -f Tcl_GetRange.3
    rm -f Tcl_AppendToObj.3
    rm -f Tcl_AppendUnicodeToObj.3
    rm -f Tcl_AppendStringsToObj.3
    rm -f Tcl_AppendStringsToObjVA.3
    rm -f Tcl_AppendObjToObj.3
    rm -f Tcl_SetObjLength.3
    rm -f Tcl_ConcatObj.3
    rm -f Tcl_AttemptSetObjLength.3
    ln StringObj.3 Tcl_NewStringObj.3
    ln StringObj.3 Tcl_NewUnicodeObj.3
    ln StringObj.3 Tcl_SetStringObj.3
    ln StringObj.3 Tcl_SetUnicodeObj.3
    ln StringObj.3 Tcl_GetStringFromObj.3
    ln StringObj.3 Tcl_GetString.3
    ln StringObj.3 Tcl_GetUnicodeFromObj.3
    ln StringObj.3 Tcl_GetUnicode.3
    ln StringObj.3 Tcl_GetUniChar.3
    ln StringObj.3 Tcl_GetCharLength.3
    ln StringObj.3 Tcl_GetRange.3
    ln StringObj.3 Tcl_AppendToObj.3
    ln StringObj.3 Tcl_AppendUnicodeToObj.3
    ln StringObj.3 Tcl_AppendStringsToObj.3
    ln StringObj.3 Tcl_AppendStringsToObjVA.3
    ln StringObj.3 Tcl_AppendObjToObj.3
    ln StringObj.3 Tcl_SetObjLength.3
    ln StringObj.3 Tcl_ConcatObj.3
    ln StringObj.3 Tcl_AttemptSetObjLength.3
fi
if test -r SubstObj.3; then


    rm -f Tcl_SubstObj.3
    ln SubstObj.3 Tcl_SubstObj.3
fi








if test -r Tcl_Main.3; then
    rm -f Tcl_SetMainLoop.3

    ln Tcl_Main.3 Tcl_SetMainLoop.3

fi
if test -r Thread.3; then


    rm -f Tcl_ConditionNotify.3
    rm -f Tcl_ConditionWait.3
    rm -f Tcl_ConditionFinalize.3
    rm -f Tcl_GetThreadData.3
    rm -f Tcl_MutexLock.3
    rm -f Tcl_MutexUnlock.3
    rm -f Tcl_MutexFinalize.3
    rm -f Tcl_CreateThread.3
    rm -f Tcl_JoinThread.3
    ln Thread.3 Tcl_ConditionNotify.3
    ln Thread.3 Tcl_ConditionWait.3
    ln Thread.3 Tcl_ConditionFinalize.3
    ln Thread.3 Tcl_GetThreadData.3
    ln Thread.3 Tcl_MutexLock.3
    ln Thread.3 Tcl_MutexUnlock.3
    ln Thread.3 Tcl_MutexFinalize.3
    ln Thread.3 Tcl_CreateThread.3
    ln Thread.3 Tcl_JoinThread.3
fi
if test -r ToUpper.3; then


    rm -f Tcl_UniCharToUpper.3
    rm -f Tcl_UniCharToLower.3
    rm -f Tcl_UniCharToTitle.3
    rm -f Tcl_UtfToUpper.3
    rm -f Tcl_UtfToLower.3
    rm -f Tcl_UtfToTitle.3
    ln ToUpper.3 Tcl_UniCharToUpper.3
    ln ToUpper.3 Tcl_UniCharToLower.3
    ln ToUpper.3 Tcl_UniCharToTitle.3
    ln ToUpper.3 Tcl_UtfToUpper.3
    ln ToUpper.3 Tcl_UtfToLower.3
    ln ToUpper.3 Tcl_UtfToTitle.3
fi
if test -r TraceCmd.3; then


    rm -f Tcl_CommandTraceInfo.3
    rm -f Tcl_TraceCommand.3
    rm -f Tcl_UntraceCommand.3
    ln TraceCmd.3 Tcl_CommandTraceInfo.3
    ln TraceCmd.3 Tcl_TraceCommand.3
    ln TraceCmd.3 Tcl_UntraceCommand.3
fi
if test -r TraceVar.3; then


    rm -f Tcl_TraceVar.3
    rm -f Tcl_TraceVar2.3
    rm -f Tcl_UntraceVar.3
    rm -f Tcl_UntraceVar2.3
    rm -f Tcl_VarTraceInfo.3
    rm -f Tcl_VarTraceInfo2.3
    ln TraceVar.3 Tcl_TraceVar.3
    ln TraceVar.3 Tcl_TraceVar2.3
    ln TraceVar.3 Tcl_UntraceVar.3
    ln TraceVar.3 Tcl_UntraceVar2.3
    ln TraceVar.3 Tcl_VarTraceInfo.3
    ln TraceVar.3 Tcl_VarTraceInfo2.3
fi
if test -r Translate.3; then


    rm -f Tcl_TranslateFileName.3
    ln Translate.3 Tcl_TranslateFileName.3
fi
if test -r UniCharIsAlpha.3; then


    rm -f Tcl_UniCharIsAlnum.3
    rm -f Tcl_UniCharIsAlpha.3
    rm -f Tcl_UniCharIsControl.3
    rm -f Tcl_UniCharIsDigit.3
    rm -f Tcl_UniCharIsGraph.3
    rm -f Tcl_UniCharIsLower.3
    rm -f Tcl_UniCharIsPrint.3
    rm -f Tcl_UniCharIsPunct.3
    rm -f Tcl_UniCharIsSpace.3
    rm -f Tcl_UniCharIsUpper.3
    rm -f Tcl_UniCharIsWordChar.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsAlnum.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsAlpha.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsControl.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsDigit.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsGraph.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsLower.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsPrint.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsPunct.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsSpace.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsUpper.3
    ln UniCharIsAlpha.3 Tcl_UniCharIsWordChar.3
fi
if test -r UpVar.3; then


    rm -f Tcl_UpVar.3
    rm -f Tcl_UpVar2.3
    ln UpVar.3 Tcl_UpVar.3
    ln UpVar.3 Tcl_UpVar2.3
fi
if test -r Utf.3; then


    rm -f Tcl_UniChar.3
    rm -f Tcl_UniCharCaseMatch.3
    rm -f Tcl_UniCharNcasecmp.3
    rm -f Tcl_UniCharToUtf.3
    rm -f Tcl_UtfToUniChar.3
    rm -f Tcl_UniCharToUtfDString.3
    rm -f Tcl_UtfToUniCharDString.3
    rm -f Tcl_UniCharLen.3
    rm -f Tcl_UniCharNcmp.3
    rm -f Tcl_UtfCharComplete.3
    rm -f Tcl_NumUtfChars.3
    rm -f Tcl_UtfFindFirst.3
    rm -f Tcl_UtfFindLast.3
    rm -f Tcl_UtfNext.3
    rm -f Tcl_UtfPrev.3
    rm -f Tcl_UniCharAtIndex.3
    rm -f Tcl_UtfAtIndex.3
    rm -f Tcl_UtfBackslash.3
    ln Utf.3 Tcl_UniChar.3
    ln Utf.3 Tcl_UniCharCaseMatch.3
    ln Utf.3 Tcl_UniCharNcasecmp.3
    ln Utf.3 Tcl_UniCharToUtf.3
    ln Utf.3 Tcl_UtfToUniChar.3
    ln Utf.3 Tcl_UniCharToUtfDString.3
    ln Utf.3 Tcl_UtfToUniCharDString.3
    ln Utf.3 Tcl_UniCharLen.3
    ln Utf.3 Tcl_UniCharNcmp.3
    ln Utf.3 Tcl_UtfCharComplete.3
    ln Utf.3 Tcl_NumUtfChars.3
    ln Utf.3 Tcl_UtfFindFirst.3
    ln Utf.3 Tcl_UtfFindLast.3
    ln Utf.3 Tcl_UtfNext.3
    ln Utf.3 Tcl_UtfPrev.3
    ln Utf.3 Tcl_UniCharAtIndex.3
    ln Utf.3 Tcl_UtfAtIndex.3
    ln Utf.3 Tcl_UtfBackslash.3
fi
if test -r WrongNumArgs.3; then

    rm -f Tcl_WrongNumArgs.3
    ln WrongNumArgs.3 Tcl_WrongNumArgs.3

fi












































































































































if test -r http.n; then



    if test "${CASEINSENSITIVEFS:-}" != "1"; then rm -f Http.n; fi



    if test "${CASEINSENSITIVEFS:-}" != "1"; then ln http.n Http.n; fi


















fi
if test -r library.n; then


    rm -f auto_execok.n
    rm -f auto_import.n
    rm -f auto_load.n
    rm -f auto_mkindex.n
    rm -f auto_mkindex_old.n
    rm -f auto_qualify.n
    rm -f auto_reset.n
    rm -f tcl_findLibrary.n
    rm -f parray.n
    rm -f tcl_endOfWord.n
    rm -f tcl_startOfNextWord.n
    rm -f tcl_startOfPreviousWord.n
    rm -f tcl_wordBreakAfter.n
    rm -f tcl_wordBreakBefore.n





























    ln library.n auto_execok.n


    ln library.n auto_import.n
    ln library.n auto_load.n


    ln library.n auto_mkindex.n
    ln library.n auto_mkindex_old.n
    ln library.n auto_qualify.n











    ln library.n auto_reset.n
    ln library.n tcl_findLibrary.n

    ln library.n parray.n
    ln library.n tcl_endOfWord.n

    ln library.n tcl_startOfNextWord.n
    ln library.n tcl_startOfPreviousWord.n
    ln library.n tcl_wordBreakAfter.n







    ln library.n tcl_wordBreakBefore.n








fi
if test -r packagens.n; then


    rm -f pkg::create.n
    ln packagens.n pkg::create.n
fi




if test -r pkgMkIndex.n; then


    rm -f pkg_mkIndex.n
    ln pkgMkIndex.n pkg_mkIndex.n












































fi
if test -r safe.n; then


    rm -f SafeBase.n
    ln safe.n SafeBase.n
fi




























































































exit 0








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|


>
>
>
>
>
>
>















>
>
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|


>
>
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|


>
>
|
|


>
|
|
>


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|


>
>
|
|
|
|


>
>
|
|
|
|
|
|
|
|


>
>
|
|


>
>
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|


>
>
|
|
|
|


>
>
|
|


>
>
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
|
|
>
>


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
|
|
>


>
>
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|


>
>
|
|
|
|


>
|
|
>


>
>
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|


>
>
|
|
|
|


>
>
|
|


>
|
|
>


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|


>
|
|
>


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|


>
>
|
|


>
>
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|


>
>
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|


>
>
|
|


>
|
|
>


>
>
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|


>
>
|
|


>
>
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|

>
>
>
>
>
>
>
>

|
>
|
>


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
>
|
|
|
|


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


>
|
|
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
|
|
>
>
|
<
|
>
>
>
>
>
>
>
>
>
>
>
|
|
>
|
|
>
|
|
|
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>


>
>
|
|

>
>
>
>

>
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


>
>
|
|

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660

1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
# Because of the length of command and procedure names, this mechanism
# only works on machines that support file names longer than 14 characters.
# This script checks to see if long file names are supported, and it
# doesn't make any links if they are not.
#
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.

ZIP=true
while true; do
    case $1 in
        -s | --symlinks )
            S=-s
            ;;
        -z | --compress )
            ZIP=$2
            shift
            ;;
        *) break
            ;;
    esac
    shift
done

if test $# != 1; then
    echo "Usage: mkLinks <options> dir"
    exit 1
fi

if test "x$ZIP" != "xtrue"; then
    touch TeST
    $ZIP TeST
    Z=`ls TeST* | sed 's/^[^.]*//'`
    rm -f TeST*
fi

cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
echo foo > xyzzyTestingaverylongfilename.foo
y=`echo xyzzyTestingav*`
rm xyzzyTe*
if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then
    exit
fi
if test "$y" != "xyzzyTestingaverylongfilename.foo"; then
    CASEINSENSITIVEFS=1
fi

if test -r Access.3; then
    rm -f Access.3.*
    $ZIP Access.3
    rm -f Tcl_Access.3 Tcl_Access.3.* 
    rm -f Tcl_Stat.3 Tcl_Stat.3.* 
    ln $S Access.3$Z Tcl_Access.3$Z 
    ln $S Access.3$Z Tcl_Stat.3$Z 
fi
if test -r AddErrInfo.3; then
    rm -f AddErrInfo.3.*
    $ZIP AddErrInfo.3
    rm -f Tcl_AddObjErrorInfo.3 Tcl_AddObjErrorInfo.3.* 
    rm -f Tcl_AddErrorInfo.3 Tcl_AddErrorInfo.3.* 
    rm -f Tcl_SetObjErrorCode.3 Tcl_SetObjErrorCode.3.* 
    rm -f Tcl_SetErrorCode.3 Tcl_SetErrorCode.3.* 
    rm -f Tcl_SetErrorCodeVA.3 Tcl_SetErrorCodeVA.3.* 
    rm -f Tcl_PosixError.3 Tcl_PosixError.3.* 
    rm -f Tcl_LogCommandInfo.3 Tcl_LogCommandInfo.3.* 
    ln $S AddErrInfo.3$Z Tcl_AddObjErrorInfo.3$Z 
    ln $S AddErrInfo.3$Z Tcl_AddErrorInfo.3$Z 
    ln $S AddErrInfo.3$Z Tcl_SetObjErrorCode.3$Z 
    ln $S AddErrInfo.3$Z Tcl_SetErrorCode.3$Z 
    ln $S AddErrInfo.3$Z Tcl_SetErrorCodeVA.3$Z 
    ln $S AddErrInfo.3$Z Tcl_PosixError.3$Z 
    ln $S AddErrInfo.3$Z Tcl_LogCommandInfo.3$Z 
fi
if test -r Alloc.3; then
    rm -f Alloc.3.*
    $ZIP Alloc.3
    rm -f Tcl_Alloc.3 Tcl_Alloc.3.* 
    rm -f Tcl_Free.3 Tcl_Free.3.* 
    rm -f Tcl_Realloc.3 Tcl_Realloc.3.* 
    rm -f Tcl_AttemptAlloc.3 Tcl_AttemptAlloc.3.* 
    rm -f Tcl_AttemptRealloc.3 Tcl_AttemptRealloc.3.* 
    rm -f ckalloc.3 ckalloc.3.* 
    rm -f ckfree.3 ckfree.3.* 
    rm -f ckrealloc.3 ckrealloc.3.* 
    rm -f attemptckalloc.3 attemptckalloc.3.* 
    rm -f attemptckrealloc.3 attemptckrealloc.3.* 
    ln $S Alloc.3$Z Tcl_Alloc.3$Z 
    ln $S Alloc.3$Z Tcl_Free.3$Z 
    ln $S Alloc.3$Z Tcl_Realloc.3$Z 
    ln $S Alloc.3$Z Tcl_AttemptAlloc.3$Z 
    ln $S Alloc.3$Z Tcl_AttemptRealloc.3$Z 
    ln $S Alloc.3$Z ckalloc.3$Z 
    ln $S Alloc.3$Z ckfree.3$Z 
    ln $S Alloc.3$Z ckrealloc.3$Z 
    ln $S Alloc.3$Z attemptckalloc.3$Z 
    ln $S Alloc.3$Z attemptckrealloc.3$Z 
fi
if test -r AllowExc.3; then
    rm -f AllowExc.3.*
    $ZIP AllowExc.3
    rm -f Tcl_AllowExceptions.3 Tcl_AllowExceptions.3.* 
    ln $S AllowExc.3$Z Tcl_AllowExceptions.3$Z 
fi
if test -r AppInit.3; then
    rm -f AppInit.3.*
    $ZIP AppInit.3
    rm -f Tcl_AppInit.3 Tcl_AppInit.3.* 
    ln $S AppInit.3$Z Tcl_AppInit.3$Z 
fi
if test -r AssocData.3; then
    rm -f AssocData.3.*
    $ZIP AssocData.3
    rm -f Tcl_GetAssocData.3 Tcl_GetAssocData.3.* 
    rm -f Tcl_SetAssocData.3 Tcl_SetAssocData.3.* 
    rm -f Tcl_DeleteAssocData.3 Tcl_DeleteAssocData.3.* 
    ln $S AssocData.3$Z Tcl_GetAssocData.3$Z 
    ln $S AssocData.3$Z Tcl_SetAssocData.3$Z 
    ln $S AssocData.3$Z Tcl_DeleteAssocData.3$Z 
fi
if test -r Async.3; then
    rm -f Async.3.*
    $ZIP Async.3
    rm -f Tcl_AsyncCreate.3 Tcl_AsyncCreate.3.* 
    rm -f Tcl_AsyncMark.3 Tcl_AsyncMark.3.* 
    rm -f Tcl_AsyncInvoke.3 Tcl_AsyncInvoke.3.* 
    rm -f Tcl_AsyncDelete.3 Tcl_AsyncDelete.3.* 
    rm -f Tcl_AsyncReady.3 Tcl_AsyncReady.3.* 
    ln $S Async.3$Z Tcl_AsyncCreate.3$Z 
    ln $S Async.3$Z Tcl_AsyncMark.3$Z 
    ln $S Async.3$Z Tcl_AsyncInvoke.3$Z 
    ln $S Async.3$Z Tcl_AsyncDelete.3$Z 
    ln $S Async.3$Z Tcl_AsyncReady.3$Z 
fi
if test -r BackgdErr.3; then
    rm -f BackgdErr.3.*
    $ZIP BackgdErr.3
    rm -f Tcl_BackgroundError.3 Tcl_BackgroundError.3.* 
    ln $S BackgdErr.3$Z Tcl_BackgroundError.3$Z 
fi
if test -r Backslash.3; then
    rm -f Backslash.3.*
    $ZIP Backslash.3
    rm -f Tcl_Backslash.3 Tcl_Backslash.3.* 
    ln $S Backslash.3$Z Tcl_Backslash.3$Z 
fi
if test -r BoolObj.3; then
    rm -f BoolObj.3.*
    $ZIP BoolObj.3
    rm -f Tcl_NewBooleanObj.3 Tcl_NewBooleanObj.3.* 
    rm -f Tcl_SetBooleanObj.3 Tcl_SetBooleanObj.3.* 
    rm -f Tcl_GetBooleanFromObj.3 Tcl_GetBooleanFromObj.3.* 
    ln $S BoolObj.3$Z Tcl_NewBooleanObj.3$Z 
    ln $S BoolObj.3$Z Tcl_SetBooleanObj.3$Z 
    ln $S BoolObj.3$Z Tcl_GetBooleanFromObj.3$Z 
fi
if test -r ByteArrObj.3; then
    rm -f ByteArrObj.3.*
    $ZIP ByteArrObj.3
    rm -f Tcl_NewByteArrayObj.3 Tcl_NewByteArrayObj.3.* 
    rm -f Tcl_SetByteArrayObj.3 Tcl_SetByteArrayObj.3.* 
    rm -f Tcl_GetByteArrayFromObj.3 Tcl_GetByteArrayFromObj.3.* 
    rm -f Tcl_SetByteArrayLength.3 Tcl_SetByteArrayLength.3.* 
    ln $S ByteArrObj.3$Z Tcl_NewByteArrayObj.3$Z 
    ln $S ByteArrObj.3$Z Tcl_SetByteArrayObj.3$Z 
    ln $S ByteArrObj.3$Z Tcl_GetByteArrayFromObj.3$Z 
    ln $S ByteArrObj.3$Z Tcl_SetByteArrayLength.3$Z 
fi
if test -r CallDel.3; then
    rm -f CallDel.3.*
    $ZIP CallDel.3
    rm -f Tcl_CallWhenDeleted.3 Tcl_CallWhenDeleted.3.* 
    rm -f Tcl_DontCallWhenDeleted.3 Tcl_DontCallWhenDeleted.3.* 
    ln $S CallDel.3$Z Tcl_CallWhenDeleted.3$Z 
    ln $S CallDel.3$Z Tcl_DontCallWhenDeleted.3$Z 
fi
if test -r ChnlStack.3; then
    rm -f ChnlStack.3.*
    $ZIP ChnlStack.3
    rm -f Tcl_StackChannel.3 Tcl_StackChannel.3.* 
    rm -f Tcl_UnstackChannel.3 Tcl_UnstackChannel.3.* 
    rm -f Tcl_GetStackedChannel.3 Tcl_GetStackedChannel.3.* 
    rm -f Tcl_GetTopChannel.3 Tcl_GetTopChannel.3.* 
    ln $S ChnlStack.3$Z Tcl_StackChannel.3$Z 
    ln $S ChnlStack.3$Z Tcl_UnstackChannel.3$Z 
    ln $S ChnlStack.3$Z Tcl_GetStackedChannel.3$Z 
    ln $S ChnlStack.3$Z Tcl_GetTopChannel.3$Z 
fi
if test -r CmdCmplt.3; then
    rm -f CmdCmplt.3.*
    $ZIP CmdCmplt.3
    rm -f Tcl_CommandComplete.3 Tcl_CommandComplete.3.* 
    ln $S CmdCmplt.3$Z Tcl_CommandComplete.3$Z 
fi
if test -r Concat.3; then
    rm -f Concat.3.*
    $ZIP Concat.3
    rm -f Tcl_Concat.3 Tcl_Concat.3.* 
    ln $S Concat.3$Z Tcl_Concat.3$Z 
fi
if test -r CrtChannel.3; then
    rm -f CrtChannel.3.*
    $ZIP CrtChannel.3
    rm -f Tcl_CreateChannel.3 Tcl_CreateChannel.3.* 
    rm -f Tcl_GetChannelInstanceData.3 Tcl_GetChannelInstanceData.3.* 
    rm -f Tcl_GetChannelType.3 Tcl_GetChannelType.3.* 
    rm -f Tcl_GetChannelName.3 Tcl_GetChannelName.3.* 
    rm -f Tcl_GetChannelHandle.3 Tcl_GetChannelHandle.3.* 
    rm -f Tcl_GetChannelMode.3 Tcl_GetChannelMode.3.* 
    rm -f Tcl_GetChannelBufferSize.3 Tcl_GetChannelBufferSize.3.* 
    rm -f Tcl_SetChannelBufferSize.3 Tcl_SetChannelBufferSize.3.* 
    rm -f Tcl_NotifyChannel.3 Tcl_NotifyChannel.3.* 
    rm -f Tcl_BadChannelOption.3 Tcl_BadChannelOption.3.* 
    rm -f Tcl_ChannelName.3 Tcl_ChannelName.3.* 
    rm -f Tcl_ChannelVersion.3 Tcl_ChannelVersion.3.* 
    rm -f Tcl_ChannelBlockModeProc.3 Tcl_ChannelBlockModeProc.3.* 
    rm -f Tcl_ChannelCloseProc.3 Tcl_ChannelCloseProc.3.* 
    rm -f Tcl_ChannelClose2Proc.3 Tcl_ChannelClose2Proc.3.* 
    rm -f Tcl_ChannelInputProc.3 Tcl_ChannelInputProc.3.* 
    rm -f Tcl_ChannelOutputProc.3 Tcl_ChannelOutputProc.3.* 
    rm -f Tcl_ChannelSeekProc.3 Tcl_ChannelSeekProc.3.* 
    rm -f Tcl_ChannelWideSeekProc.3 Tcl_ChannelWideSeekProc.3.* 
    rm -f Tcl_ChannelSetOptionProc.3 Tcl_ChannelSetOptionProc.3.* 
    rm -f Tcl_ChannelGetOptionProc.3 Tcl_ChannelGetOptionProc.3.* 
    rm -f Tcl_ChannelWatchProc.3 Tcl_ChannelWatchProc.3.* 
    rm -f Tcl_ChannelGetHandleProc.3 Tcl_ChannelGetHandleProc.3.* 
    rm -f Tcl_ChannelFlushProc.3 Tcl_ChannelFlushProc.3.* 
    rm -f Tcl_ChannelHandlerProc.3 Tcl_ChannelHandlerProc.3.* 
    rm -f Tcl_IsChannelShared.3 Tcl_IsChannelShared.3.* 
    rm -f Tcl_IsChannelRegistered.3 Tcl_IsChannelRegistered.3.* 
    rm -f Tcl_CutChannel.3 Tcl_CutChannel.3.* 
    rm -f Tcl_SpliceChannel.3 Tcl_SpliceChannel.3.* 
    rm -f Tcl_IsChannelExisting.3 Tcl_IsChannelExisting.3.* 
    rm -f Tcl_ClearChannelHandlers.3 Tcl_ClearChannelHandlers.3.* 
    rm -f Tcl_GetChannelThread.3 Tcl_GetChannelThread.3.* 
    rm -f Tcl_ChannelBuffered.3 Tcl_ChannelBuffered.3.* 
    ln $S CrtChannel.3$Z Tcl_CreateChannel.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelInstanceData.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelType.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelName.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelHandle.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelMode.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelBufferSize.3$Z 
    ln $S CrtChannel.3$Z Tcl_SetChannelBufferSize.3$Z 
    ln $S CrtChannel.3$Z Tcl_NotifyChannel.3$Z 
    ln $S CrtChannel.3$Z Tcl_BadChannelOption.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelName.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelVersion.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelBlockModeProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelCloseProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelClose2Proc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelInputProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelOutputProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelSeekProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelWideSeekProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelSetOptionProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelGetOptionProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelWatchProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelGetHandleProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelFlushProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelHandlerProc.3$Z 
    ln $S CrtChannel.3$Z Tcl_IsChannelShared.3$Z 
    ln $S CrtChannel.3$Z Tcl_IsChannelRegistered.3$Z 
    ln $S CrtChannel.3$Z Tcl_CutChannel.3$Z 
    ln $S CrtChannel.3$Z Tcl_SpliceChannel.3$Z 
    ln $S CrtChannel.3$Z Tcl_IsChannelExisting.3$Z 
    ln $S CrtChannel.3$Z Tcl_ClearChannelHandlers.3$Z 
    ln $S CrtChannel.3$Z Tcl_GetChannelThread.3$Z 
    ln $S CrtChannel.3$Z Tcl_ChannelBuffered.3$Z 
fi
if test -r CrtChnlHdlr.3; then
    rm -f CrtChnlHdlr.3.*
    $ZIP CrtChnlHdlr.3
    rm -f Tcl_CreateChannelHandler.3 Tcl_CreateChannelHandler.3.* 
    rm -f Tcl_DeleteChannelHandler.3 Tcl_DeleteChannelHandler.3.* 
    ln $S CrtChnlHdlr.3$Z Tcl_CreateChannelHandler.3$Z 
    ln $S CrtChnlHdlr.3$Z Tcl_DeleteChannelHandler.3$Z 
fi
if test -r CrtCloseHdlr.3; then
    rm -f CrtCloseHdlr.3.*
    $ZIP CrtCloseHdlr.3
    rm -f Tcl_CreateCloseHandler.3 Tcl_CreateCloseHandler.3.* 
    rm -f Tcl_DeleteCloseHandler.3 Tcl_DeleteCloseHandler.3.* 
    ln $S CrtCloseHdlr.3$Z Tcl_CreateCloseHandler.3$Z 
    ln $S CrtCloseHdlr.3$Z Tcl_DeleteCloseHandler.3$Z 
fi
if test -r CrtCommand.3; then
    rm -f CrtCommand.3.*
    $ZIP CrtCommand.3
    rm -f Tcl_CreateCommand.3 Tcl_CreateCommand.3.* 
    ln $S CrtCommand.3$Z Tcl_CreateCommand.3$Z 
fi
if test -r CrtFileHdlr.3; then
    rm -f CrtFileHdlr.3.*
    $ZIP CrtFileHdlr.3
    rm -f Tcl_CreateFileHandler.3 Tcl_CreateFileHandler.3.* 
    rm -f Tcl_DeleteFileHandler.3 Tcl_DeleteFileHandler.3.* 
    ln $S CrtFileHdlr.3$Z Tcl_CreateFileHandler.3$Z 
    ln $S CrtFileHdlr.3$Z Tcl_DeleteFileHandler.3$Z 
fi
if test -r CrtInterp.3; then
    rm -f CrtInterp.3.*
    $ZIP CrtInterp.3
    rm -f Tcl_CreateInterp.3 Tcl_CreateInterp.3.* 
    rm -f Tcl_DeleteInterp.3 Tcl_DeleteInterp.3.* 
    rm -f Tcl_InterpDeleted.3 Tcl_InterpDeleted.3.* 
    ln $S CrtInterp.3$Z Tcl_CreateInterp.3$Z 
    ln $S CrtInterp.3$Z Tcl_DeleteInterp.3$Z 
    ln $S CrtInterp.3$Z Tcl_InterpDeleted.3$Z 
fi
if test -r CrtMathFnc.3; then
    rm -f CrtMathFnc.3.*
    $ZIP CrtMathFnc.3
    rm -f Tcl_CreateMathFunc.3 Tcl_CreateMathFunc.3.* 
    rm -f Tcl_GetMathFuncInfo.3 Tcl_GetMathFuncInfo.3.* 
    rm -f Tcl_ListMathFuncs.3 Tcl_ListMathFuncs.3.* 
    ln $S CrtMathFnc.3$Z Tcl_CreateMathFunc.3$Z 
    ln $S CrtMathFnc.3$Z Tcl_GetMathFuncInfo.3$Z 
    ln $S CrtMathFnc.3$Z Tcl_ListMathFuncs.3$Z 
fi
if test -r CrtObjCmd.3; then
    rm -f CrtObjCmd.3.*
    $ZIP CrtObjCmd.3
    rm -f Tcl_CreateObjCommand.3 Tcl_CreateObjCommand.3.* 
    rm -f Tcl_DeleteCommand.3 Tcl_DeleteCommand.3.* 
    rm -f Tcl_DeleteCommandFromToken.3 Tcl_DeleteCommandFromToken.3.* 
    rm -f Tcl_GetCommandInfo.3 Tcl_GetCommandInfo.3.* 
    rm -f Tcl_GetCommandInfoFromToken.3 Tcl_GetCommandInfoFromToken.3.* 
    rm -f Tcl_SetCommandInfo.3 Tcl_SetCommandInfo.3.* 
    rm -f Tcl_SetCommandInfoFromToken.3 Tcl_SetCommandInfoFromToken.3.* 
    rm -f Tcl_GetCommandName.3 Tcl_GetCommandName.3.* 
    rm -f Tcl_GetCommandFullName.3 Tcl_GetCommandFullName.3.* 
    rm -f Tcl_GetCommandFromObj.3 Tcl_GetCommandFromObj.3.* 
    ln $S CrtObjCmd.3$Z Tcl_CreateObjCommand.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_DeleteCommand.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_DeleteCommandFromToken.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_GetCommandInfo.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_GetCommandInfoFromToken.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_SetCommandInfo.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_SetCommandInfoFromToken.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_GetCommandName.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_GetCommandFullName.3$Z 
    ln $S CrtObjCmd.3$Z Tcl_GetCommandFromObj.3$Z 
fi
if test -r CrtSlave.3; then
    rm -f CrtSlave.3.*
    $ZIP CrtSlave.3
    rm -f Tcl_IsSafe.3 Tcl_IsSafe.3.* 
    rm -f Tcl_MakeSafe.3 Tcl_MakeSafe.3.* 
    rm -f Tcl_CreateSlave.3 Tcl_CreateSlave.3.* 
    rm -f Tcl_GetSlave.3 Tcl_GetSlave.3.* 
    rm -f Tcl_GetMaster.3 Tcl_GetMaster.3.* 
    rm -f Tcl_GetInterpPath.3 Tcl_GetInterpPath.3.* 
    rm -f Tcl_CreateAlias.3 Tcl_CreateAlias.3.* 
    rm -f Tcl_CreateAliasObj.3 Tcl_CreateAliasObj.3.* 
    rm -f Tcl_GetAlias.3 Tcl_GetAlias.3.* 
    rm -f Tcl_GetAliasObj.3 Tcl_GetAliasObj.3.* 
    rm -f Tcl_ExposeCommand.3 Tcl_ExposeCommand.3.* 
    rm -f Tcl_HideCommand.3 Tcl_HideCommand.3.* 
    ln $S CrtSlave.3$Z Tcl_IsSafe.3$Z 
    ln $S CrtSlave.3$Z Tcl_MakeSafe.3$Z 
    ln $S CrtSlave.3$Z Tcl_CreateSlave.3$Z 
    ln $S CrtSlave.3$Z Tcl_GetSlave.3$Z 
    ln $S CrtSlave.3$Z Tcl_GetMaster.3$Z 
    ln $S CrtSlave.3$Z Tcl_GetInterpPath.3$Z 
    ln $S CrtSlave.3$Z Tcl_CreateAlias.3$Z 
    ln $S CrtSlave.3$Z Tcl_CreateAliasObj.3$Z 
    ln $S CrtSlave.3$Z Tcl_GetAlias.3$Z 
    ln $S CrtSlave.3$Z Tcl_GetAliasObj.3$Z 
    ln $S CrtSlave.3$Z Tcl_ExposeCommand.3$Z 
    ln $S CrtSlave.3$Z Tcl_HideCommand.3$Z 
fi
if test -r CrtTimerHdlr.3; then
    rm -f CrtTimerHdlr.3.*
    $ZIP CrtTimerHdlr.3
    rm -f Tcl_CreateTimerHandler.3 Tcl_CreateTimerHandler.3.* 
    rm -f Tcl_DeleteTimerHandler.3 Tcl_DeleteTimerHandler.3.* 
    ln $S CrtTimerHdlr.3$Z Tcl_CreateTimerHandler.3$Z 
    ln $S CrtTimerHdlr.3$Z Tcl_DeleteTimerHandler.3$Z 
fi
if test -r CrtTrace.3; then
    rm -f CrtTrace.3.*
    $ZIP CrtTrace.3
    rm -f Tcl_CreateTrace.3 Tcl_CreateTrace.3.* 
    rm -f Tcl_CreateObjTrace.3 Tcl_CreateObjTrace.3.* 
    rm -f Tcl_DeleteTrace.3 Tcl_DeleteTrace.3.* 
    ln $S CrtTrace.3$Z Tcl_CreateTrace.3$Z 
    ln $S CrtTrace.3$Z Tcl_CreateObjTrace.3$Z 
    ln $S CrtTrace.3$Z Tcl_DeleteTrace.3$Z 
fi
if test -r DString.3; then
    rm -f DString.3.*
    $ZIP DString.3
    rm -f Tcl_DStringInit.3 Tcl_DStringInit.3.* 
    rm -f Tcl_DStringAppend.3 Tcl_DStringAppend.3.* 
    rm -f Tcl_DStringAppendElement.3 Tcl_DStringAppendElement.3.* 
    rm -f Tcl_DStringStartSublist.3 Tcl_DStringStartSublist.3.* 
    rm -f Tcl_DStringEndSublist.3 Tcl_DStringEndSublist.3.* 
    rm -f Tcl_DStringLength.3 Tcl_DStringLength.3.* 
    rm -f Tcl_DStringValue.3 Tcl_DStringValue.3.* 
    rm -f Tcl_DStringSetLength.3 Tcl_DStringSetLength.3.* 
    rm -f Tcl_DStringTrunc.3 Tcl_DStringTrunc.3.* 
    rm -f Tcl_DStringFree.3 Tcl_DStringFree.3.* 
    rm -f Tcl_DStringResult.3 Tcl_DStringResult.3.* 
    rm -f Tcl_DStringGetResult.3 Tcl_DStringGetResult.3.* 
    ln $S DString.3$Z Tcl_DStringInit.3$Z 
    ln $S DString.3$Z Tcl_DStringAppend.3$Z 
    ln $S DString.3$Z Tcl_DStringAppendElement.3$Z 
    ln $S DString.3$Z Tcl_DStringStartSublist.3$Z 
    ln $S DString.3$Z Tcl_DStringEndSublist.3$Z 
    ln $S DString.3$Z Tcl_DStringLength.3$Z 
    ln $S DString.3$Z Tcl_DStringValue.3$Z 
    ln $S DString.3$Z Tcl_DStringSetLength.3$Z 
    ln $S DString.3$Z Tcl_DStringTrunc.3$Z 
    ln $S DString.3$Z Tcl_DStringFree.3$Z 
    ln $S DString.3$Z Tcl_DStringResult.3$Z 
    ln $S DString.3$Z Tcl_DStringGetResult.3$Z 
fi
if test -r DetachPids.3; then
    rm -f DetachPids.3.*
    $ZIP DetachPids.3
    rm -f Tcl_DetachPids.3 Tcl_DetachPids.3.* 
    rm -f Tcl_ReapDetachedProcs.3 Tcl_ReapDetachedProcs.3.* 
    rm -f Tcl_WaitPid.3 Tcl_WaitPid.3.* 
    ln $S DetachPids.3$Z Tcl_DetachPids.3$Z 
    ln $S DetachPids.3$Z Tcl_ReapDetachedProcs.3$Z 
    ln $S DetachPids.3$Z Tcl_WaitPid.3$Z 
fi
if test -r DoOneEvent.3; then
    rm -f DoOneEvent.3.*
    $ZIP DoOneEvent.3
    rm -f Tcl_DoOneEvent.3 Tcl_DoOneEvent.3.* 
    ln $S DoOneEvent.3$Z Tcl_DoOneEvent.3$Z 
fi
if test -r DoWhenIdle.3; then
    rm -f DoWhenIdle.3.*
    $ZIP DoWhenIdle.3
    rm -f Tcl_DoWhenIdle.3 Tcl_DoWhenIdle.3.* 
    rm -f Tcl_CancelIdleCall.3 Tcl_CancelIdleCall.3.* 
    ln $S DoWhenIdle.3$Z Tcl_DoWhenIdle.3$Z 
    ln $S DoWhenIdle.3$Z Tcl_CancelIdleCall.3$Z 
fi
if test -r DoubleObj.3; then
    rm -f DoubleObj.3.*
    $ZIP DoubleObj.3
    rm -f Tcl_NewDoubleObj.3 Tcl_NewDoubleObj.3.* 
    rm -f Tcl_SetDoubleObj.3 Tcl_SetDoubleObj.3.* 
    rm -f Tcl_GetDoubleFromObj.3 Tcl_GetDoubleFromObj.3.* 
    ln $S DoubleObj.3$Z Tcl_NewDoubleObj.3$Z 
    ln $S DoubleObj.3$Z Tcl_SetDoubleObj.3$Z 
    ln $S DoubleObj.3$Z Tcl_GetDoubleFromObj.3$Z 
fi
if test -r DumpActiveMemory.3; then
    rm -f DumpActiveMemory.3.*
    $ZIP DumpActiveMemory.3
    rm -f Tcl_DumpActiveMemory.3 Tcl_DumpActiveMemory.3.* 
    rm -f Tcl_InitMemory.3 Tcl_InitMemory.3.* 
    rm -f Tcl_ValidateAllMemory.3 Tcl_ValidateAllMemory.3.* 
    ln $S DumpActiveMemory.3$Z Tcl_DumpActiveMemory.3$Z 
    ln $S DumpActiveMemory.3$Z Tcl_InitMemory.3$Z 
    ln $S DumpActiveMemory.3$Z Tcl_ValidateAllMemory.3$Z 
fi
if test -r Encoding.3; then
    rm -f Encoding.3.*
    $ZIP Encoding.3
    rm -f Tcl_GetEncoding.3 Tcl_GetEncoding.3.* 
    rm -f Tcl_FreeEncoding.3 Tcl_FreeEncoding.3.* 
    rm -f Tcl_ExternalToUtfDString.3 Tcl_ExternalToUtfDString.3.* 
    rm -f Tcl_ExternalToUtf.3 Tcl_ExternalToUtf.3.* 
    rm -f Tcl_UtfToExternalDString.3 Tcl_UtfToExternalDString.3.* 
    rm -f Tcl_UtfToExternal.3 Tcl_UtfToExternal.3.* 
    rm -f Tcl_WinTCharToUtf.3 Tcl_WinTCharToUtf.3.* 
    rm -f Tcl_WinUtfToTChar.3 Tcl_WinUtfToTChar.3.* 
    rm -f Tcl_GetEncodingName.3 Tcl_GetEncodingName.3.* 
    rm -f Tcl_SetSystemEncoding.3 Tcl_SetSystemEncoding.3.* 
    rm -f Tcl_GetEncodingNames.3 Tcl_GetEncodingNames.3.* 
    rm -f Tcl_CreateEncoding.3 Tcl_CreateEncoding.3.* 
    rm -f Tcl_GetDefaultEncodingDir.3 Tcl_GetDefaultEncodingDir.3.* 
    rm -f Tcl_SetDefaultEncodingDir.3 Tcl_SetDefaultEncodingDir.3.* 
    ln $S Encoding.3$Z Tcl_GetEncoding.3$Z 
    ln $S Encoding.3$Z Tcl_FreeEncoding.3$Z 
    ln $S Encoding.3$Z Tcl_ExternalToUtfDString.3$Z 
    ln $S Encoding.3$Z Tcl_ExternalToUtf.3$Z 
    ln $S Encoding.3$Z Tcl_UtfToExternalDString.3$Z 
    ln $S Encoding.3$Z Tcl_UtfToExternal.3$Z 
    ln $S Encoding.3$Z Tcl_WinTCharToUtf.3$Z 
    ln $S Encoding.3$Z Tcl_WinUtfToTChar.3$Z 
    ln $S Encoding.3$Z Tcl_GetEncodingName.3$Z 
    ln $S Encoding.3$Z Tcl_SetSystemEncoding.3$Z 
    ln $S Encoding.3$Z Tcl_GetEncodingNames.3$Z 
    ln $S Encoding.3$Z Tcl_CreateEncoding.3$Z 
    ln $S Encoding.3$Z Tcl_GetDefaultEncodingDir.3$Z 
    ln $S Encoding.3$Z Tcl_SetDefaultEncodingDir.3$Z 
fi
if test -r Environment.3; then
    rm -f Environment.3.*
    $ZIP Environment.3
    rm -f Tcl_PutEnv.3 Tcl_PutEnv.3.* 
    ln $S Environment.3$Z Tcl_PutEnv.3$Z 
fi
if test -r Eval.3; then
    rm -f Eval.3.*
    $ZIP Eval.3
    rm -f Tcl_EvalObjEx.3 Tcl_EvalObjEx.3.* 
    rm -f Tcl_EvalFile.3 Tcl_EvalFile.3.* 
    rm -f Tcl_EvalObjv.3 Tcl_EvalObjv.3.* 
    rm -f Tcl_Eval.3 Tcl_Eval.3.* 
    rm -f Tcl_EvalEx.3 Tcl_EvalEx.3.* 
    rm -f Tcl_GlobalEval.3 Tcl_GlobalEval.3.* 
    rm -f Tcl_GlobalEvalObj.3 Tcl_GlobalEvalObj.3.* 
    rm -f Tcl_VarEval.3 Tcl_VarEval.3.* 
    rm -f Tcl_VarEvalVA.3 Tcl_VarEvalVA.3.* 
    ln $S Eval.3$Z Tcl_EvalObjEx.3$Z 
    ln $S Eval.3$Z Tcl_EvalFile.3$Z 
    ln $S Eval.3$Z Tcl_EvalObjv.3$Z 
    ln $S Eval.3$Z Tcl_Eval.3$Z 
    ln $S Eval.3$Z Tcl_EvalEx.3$Z 
    ln $S Eval.3$Z Tcl_GlobalEval.3$Z 
    ln $S Eval.3$Z Tcl_GlobalEvalObj.3$Z 
    ln $S Eval.3$Z Tcl_VarEval.3$Z 
    ln $S Eval.3$Z Tcl_VarEvalVA.3$Z 
fi
if test -r Exit.3; then
    rm -f Exit.3.*
    $ZIP Exit.3
    rm -f Tcl_Exit.3 Tcl_Exit.3.* 
    rm -f Tcl_Finalize.3 Tcl_Finalize.3.* 
    rm -f Tcl_CreateExitHandler.3 Tcl_CreateExitHandler.3.* 
    rm -f Tcl_DeleteExitHandler.3 Tcl_DeleteExitHandler.3.* 
    rm -f Tcl_ExitThread.3 Tcl_ExitThread.3.* 
    rm -f Tcl_FinalizeThread.3 Tcl_FinalizeThread.3.* 
    rm -f Tcl_CreateThreadExitHandler.3 Tcl_CreateThreadExitHandler.3.* 
    rm -f Tcl_DeleteThreadExitHandler.3 Tcl_DeleteThreadExitHandler.3.* 
    ln $S Exit.3$Z Tcl_Exit.3$Z 
    ln $S Exit.3$Z Tcl_Finalize.3$Z 
    ln $S Exit.3$Z Tcl_CreateExitHandler.3$Z 
    ln $S Exit.3$Z Tcl_DeleteExitHandler.3$Z 
    ln $S Exit.3$Z Tcl_ExitThread.3$Z 
    ln $S Exit.3$Z Tcl_FinalizeThread.3$Z 
    ln $S Exit.3$Z Tcl_CreateThreadExitHandler.3$Z 
    ln $S Exit.3$Z Tcl_DeleteThreadExitHandler.3$Z 
fi
if test -r ExprLong.3; then
    rm -f ExprLong.3.*
    $ZIP ExprLong.3
    rm -f Tcl_ExprLong.3 Tcl_ExprLong.3.* 
    rm -f Tcl_ExprDouble.3 Tcl_ExprDouble.3.* 
    rm -f Tcl_ExprBoolean.3 Tcl_ExprBoolean.3.* 
    rm -f Tcl_ExprString.3 Tcl_ExprString.3.* 
    ln $S ExprLong.3$Z Tcl_ExprLong.3$Z 
    ln $S ExprLong.3$Z Tcl_ExprDouble.3$Z 
    ln $S ExprLong.3$Z Tcl_ExprBoolean.3$Z 
    ln $S ExprLong.3$Z Tcl_ExprString.3$Z 
fi
if test -r ExprLongObj.3; then
    rm -f ExprLongObj.3.*
    $ZIP ExprLongObj.3
    rm -f Tcl_ExprLongObj.3 Tcl_ExprLongObj.3.* 
    rm -f Tcl_ExprDoubleObj.3 Tcl_ExprDoubleObj.3.* 
    rm -f Tcl_ExprBooleanObj.3 Tcl_ExprBooleanObj.3.* 
    rm -f Tcl_ExprObj.3 Tcl_ExprObj.3.* 
    ln $S ExprLongObj.3$Z Tcl_ExprLongObj.3$Z 
    ln $S ExprLongObj.3$Z Tcl_ExprDoubleObj.3$Z 
    ln $S ExprLongObj.3$Z Tcl_ExprBooleanObj.3$Z 
    ln $S ExprLongObj.3$Z Tcl_ExprObj.3$Z 
fi
if test -r FileSystem.3; then
    rm -f FileSystem.3.*
    $ZIP FileSystem.3
    rm -f Tcl_FSRegister.3 Tcl_FSRegister.3.* 
    rm -f Tcl_FSUnregister.3 Tcl_FSUnregister.3.* 
    rm -f Tcl_FSData.3 Tcl_FSData.3.* 
    rm -f Tcl_FSMountsChanged.3 Tcl_FSMountsChanged.3.* 
    rm -f Tcl_FSGetFileSystemForPath.3 Tcl_FSGetFileSystemForPath.3.* 
    rm -f Tcl_FSGetPathType.3 Tcl_FSGetPathType.3.* 
    rm -f Tcl_FSCopyFile.3 Tcl_FSCopyFile.3.* 
    rm -f Tcl_FSCopyDirectory.3 Tcl_FSCopyDirectory.3.* 
    rm -f Tcl_FSCreateDirectory.3 Tcl_FSCreateDirectory.3.* 
    rm -f Tcl_FSDeleteFile.3 Tcl_FSDeleteFile.3.* 
    rm -f Tcl_FSRemoveDirectory.3 Tcl_FSRemoveDirectory.3.* 
    rm -f Tcl_FSRenameFile.3 Tcl_FSRenameFile.3.* 
    rm -f Tcl_FSListVolumes.3 Tcl_FSListVolumes.3.* 
    rm -f Tcl_FSEvalFile.3 Tcl_FSEvalFile.3.* 
    rm -f Tcl_FSLoadFile.3 Tcl_FSLoadFile.3.* 
    rm -f Tcl_FSMatchInDirectory.3 Tcl_FSMatchInDirectory.3.* 
    rm -f Tcl_FSLink.3 Tcl_FSLink.3.* 
    rm -f Tcl_FSLstat.3 Tcl_FSLstat.3.* 
    rm -f Tcl_FSUtime.3 Tcl_FSUtime.3.* 
    rm -f Tcl_FSFileAttrsGet.3 Tcl_FSFileAttrsGet.3.* 
    rm -f Tcl_FSFileAttrsSet.3 Tcl_FSFileAttrsSet.3.* 
    rm -f Tcl_FSFileAttrStrings.3 Tcl_FSFileAttrStrings.3.* 
    rm -f Tcl_FSStat.3 Tcl_FSStat.3.* 
    rm -f Tcl_FSAccess.3 Tcl_FSAccess.3.* 
    rm -f Tcl_FSOpenFileChannel.3 Tcl_FSOpenFileChannel.3.* 
    rm -f Tcl_FSGetCwd.3 Tcl_FSGetCwd.3.* 
    rm -f Tcl_FSChdir.3 Tcl_FSChdir.3.* 
    rm -f Tcl_FSPathSeparator.3 Tcl_FSPathSeparator.3.* 
    rm -f Tcl_FSJoinPath.3 Tcl_FSJoinPath.3.* 
    rm -f Tcl_FSSplitPath.3 Tcl_FSSplitPath.3.* 
    rm -f Tcl_FSEqualPaths.3 Tcl_FSEqualPaths.3.* 
    rm -f Tcl_FSGetNormalizedPath.3 Tcl_FSGetNormalizedPath.3.* 
    rm -f Tcl_FSJoinToPath.3 Tcl_FSJoinToPath.3.* 
    rm -f Tcl_FSConvertToPathType.3 Tcl_FSConvertToPathType.3.* 
    rm -f Tcl_FSGetInternalRep.3 Tcl_FSGetInternalRep.3.* 
    rm -f Tcl_FSGetTranslatedPath.3 Tcl_FSGetTranslatedPath.3.* 
    rm -f Tcl_FSGetTranslatedStringPath.3 Tcl_FSGetTranslatedStringPath.3.* 
    rm -f Tcl_FSNewNativePath.3 Tcl_FSNewNativePath.3.* 
    rm -f Tcl_FSGetNativePath.3 Tcl_FSGetNativePath.3.* 
    rm -f Tcl_FSFileSystemInfo.3 Tcl_FSFileSystemInfo.3.* 
    rm -f Tcl_AllocStatBuf.3 Tcl_AllocStatBuf.3.* 
    ln $S FileSystem.3$Z Tcl_FSRegister.3$Z 
    ln $S FileSystem.3$Z Tcl_FSUnregister.3$Z 
    ln $S FileSystem.3$Z Tcl_FSData.3$Z 
    ln $S FileSystem.3$Z Tcl_FSMountsChanged.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetFileSystemForPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetPathType.3$Z 
    ln $S FileSystem.3$Z Tcl_FSCopyFile.3$Z 
    ln $S FileSystem.3$Z Tcl_FSCopyDirectory.3$Z 
    ln $S FileSystem.3$Z Tcl_FSCreateDirectory.3$Z 
    ln $S FileSystem.3$Z Tcl_FSDeleteFile.3$Z 
    ln $S FileSystem.3$Z Tcl_FSRemoveDirectory.3$Z 
    ln $S FileSystem.3$Z Tcl_FSRenameFile.3$Z 
    ln $S FileSystem.3$Z Tcl_FSListVolumes.3$Z 
    ln $S FileSystem.3$Z Tcl_FSEvalFile.3$Z 
    ln $S FileSystem.3$Z Tcl_FSLoadFile.3$Z 
    ln $S FileSystem.3$Z Tcl_FSMatchInDirectory.3$Z 
    ln $S FileSystem.3$Z Tcl_FSLink.3$Z 
    ln $S FileSystem.3$Z Tcl_FSLstat.3$Z 
    ln $S FileSystem.3$Z Tcl_FSUtime.3$Z 
    ln $S FileSystem.3$Z Tcl_FSFileAttrsGet.3$Z 
    ln $S FileSystem.3$Z Tcl_FSFileAttrsSet.3$Z 
    ln $S FileSystem.3$Z Tcl_FSFileAttrStrings.3$Z 
    ln $S FileSystem.3$Z Tcl_FSStat.3$Z 
    ln $S FileSystem.3$Z Tcl_FSAccess.3$Z 
    ln $S FileSystem.3$Z Tcl_FSOpenFileChannel.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetCwd.3$Z 
    ln $S FileSystem.3$Z Tcl_FSChdir.3$Z 
    ln $S FileSystem.3$Z Tcl_FSPathSeparator.3$Z 
    ln $S FileSystem.3$Z Tcl_FSJoinPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSSplitPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSEqualPaths.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetNormalizedPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSJoinToPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSConvertToPathType.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetInternalRep.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetTranslatedPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetTranslatedStringPath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSNewNativePath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSGetNativePath.3$Z 
    ln $S FileSystem.3$Z Tcl_FSFileSystemInfo.3$Z 
    ln $S FileSystem.3$Z Tcl_AllocStatBuf.3$Z 
fi
if test -r FindExec.3; then
    rm -f FindExec.3.*
    $ZIP FindExec.3
    rm -f Tcl_FindExecutable.3 Tcl_FindExecutable.3.* 
    rm -f Tcl_GetNameOfExecutable.3 Tcl_GetNameOfExecutable.3.* 
    ln $S FindExec.3$Z Tcl_FindExecutable.3$Z 
    ln $S FindExec.3$Z Tcl_GetNameOfExecutable.3$Z 
fi
if test -r GetCwd.3; then
    rm -f GetCwd.3.*
    $ZIP GetCwd.3
    rm -f Tcl_GetCwd.3 Tcl_GetCwd.3.* 
    rm -f Tcl_Chdir.3 Tcl_Chdir.3.* 
    ln $S GetCwd.3$Z Tcl_GetCwd.3$Z 
    ln $S GetCwd.3$Z Tcl_Chdir.3$Z 
fi
if test -r GetHostName.3; then
    rm -f GetHostName.3.*
    $ZIP GetHostName.3
    rm -f Tcl_GetHostName.3 Tcl_GetHostName.3.* 
    ln $S GetHostName.3$Z Tcl_GetHostName.3$Z 
fi
if test -r GetIndex.3; then
    rm -f GetIndex.3.*
    $ZIP GetIndex.3
    rm -f Tcl_GetIndexFromObj.3 Tcl_GetIndexFromObj.3.* 
    rm -f Tcl_GetIndexFromObjStruct.3 Tcl_GetIndexFromObjStruct.3.* 
    ln $S GetIndex.3$Z Tcl_GetIndexFromObj.3$Z 
    ln $S GetIndex.3$Z Tcl_GetIndexFromObjStruct.3$Z 
fi
if test -r GetInt.3; then
    rm -f GetInt.3.*
    $ZIP GetInt.3
    rm -f Tcl_GetInt.3 Tcl_GetInt.3.* 
    rm -f Tcl_GetDouble.3 Tcl_GetDouble.3.* 
    rm -f Tcl_GetBoolean.3 Tcl_GetBoolean.3.* 
    ln $S GetInt.3$Z Tcl_GetInt.3$Z 
    ln $S GetInt.3$Z Tcl_GetDouble.3$Z 
    ln $S GetInt.3$Z Tcl_GetBoolean.3$Z 
fi
if test -r GetOpnFl.3; then
    rm -f GetOpnFl.3.*
    $ZIP GetOpnFl.3
    rm -f Tcl_GetOpenFile.3 Tcl_GetOpenFile.3.* 
    ln $S GetOpnFl.3$Z Tcl_GetOpenFile.3$Z 
fi
if test -r GetStdChan.3; then
    rm -f GetStdChan.3.*
    $ZIP GetStdChan.3
    rm -f Tcl_GetStdChannel.3 Tcl_GetStdChannel.3.* 
    rm -f Tcl_SetStdChannel.3 Tcl_SetStdChannel.3.* 
    ln $S GetStdChan.3$Z Tcl_GetStdChannel.3$Z 
    ln $S GetStdChan.3$Z Tcl_SetStdChannel.3$Z 
fi
if test -r GetTime.3; then
    rm -f GetTime.3.*
    $ZIP GetTime.3
    rm -f Tcl_GetTime.3 Tcl_GetTime.3.* 
    ln $S GetTime.3$Z Tcl_GetTime.3$Z 
fi
if test -r GetVersion.3; then
    rm -f GetVersion.3.*
    $ZIP GetVersion.3
    rm -f Tcl_GetVersion.3 Tcl_GetVersion.3.* 
    ln $S GetVersion.3$Z Tcl_GetVersion.3$Z 
fi
if test -r Hash.3; then
    rm -f Hash.3.*
    $ZIP Hash.3
    rm -f Tcl_InitHashTable.3 Tcl_InitHashTable.3.* 
    rm -f Tcl_InitCustomHashTable.3 Tcl_InitCustomHashTable.3.* 
    rm -f Tcl_InitObjHashTable.3 Tcl_InitObjHashTable.3.* 
    rm -f Tcl_DeleteHashTable.3 Tcl_DeleteHashTable.3.* 
    rm -f Tcl_CreateHashEntry.3 Tcl_CreateHashEntry.3.* 
    rm -f Tcl_DeleteHashEntry.3 Tcl_DeleteHashEntry.3.* 
    rm -f Tcl_FindHashEntry.3 Tcl_FindHashEntry.3.* 
    rm -f Tcl_GetHashValue.3 Tcl_GetHashValue.3.* 
    rm -f Tcl_SetHashValue.3 Tcl_SetHashValue.3.* 
    rm -f Tcl_GetHashKey.3 Tcl_GetHashKey.3.* 
    rm -f Tcl_FirstHashEntry.3 Tcl_FirstHashEntry.3.* 
    rm -f Tcl_NextHashEntry.3 Tcl_NextHashEntry.3.* 
    rm -f Tcl_HashStats.3 Tcl_HashStats.3.* 
    ln $S Hash.3$Z Tcl_InitHashTable.3$Z 
    ln $S Hash.3$Z Tcl_InitCustomHashTable.3$Z 
    ln $S Hash.3$Z Tcl_InitObjHashTable.3$Z 
    ln $S Hash.3$Z Tcl_DeleteHashTable.3$Z 
    ln $S Hash.3$Z Tcl_CreateHashEntry.3$Z 
    ln $S Hash.3$Z Tcl_DeleteHashEntry.3$Z 
    ln $S Hash.3$Z Tcl_FindHashEntry.3$Z 
    ln $S Hash.3$Z Tcl_GetHashValue.3$Z 
    ln $S Hash.3$Z Tcl_SetHashValue.3$Z 
    ln $S Hash.3$Z Tcl_GetHashKey.3$Z 
    ln $S Hash.3$Z Tcl_FirstHashEntry.3$Z 
    ln $S Hash.3$Z Tcl_NextHashEntry.3$Z 
    ln $S Hash.3$Z Tcl_HashStats.3$Z 
fi
if test -r Init.3; then
    rm -f Init.3.*
    $ZIP Init.3
    rm -f Tcl_Init.3 Tcl_Init.3.* 
    ln $S Init.3$Z Tcl_Init.3$Z 
fi
if test -r InitStubs.3; then
    rm -f InitStubs.3.*
    $ZIP InitStubs.3
    rm -f Tcl_InitStubs.3 Tcl_InitStubs.3.* 
    ln $S InitStubs.3$Z Tcl_InitStubs.3$Z 
fi
if test -r IntObj.3; then
    rm -f IntObj.3.*
    $ZIP IntObj.3
    rm -f Tcl_NewIntObj.3 Tcl_NewIntObj.3.* 
    rm -f Tcl_NewLongObj.3 Tcl_NewLongObj.3.* 
    rm -f Tcl_NewWideIntObj.3 Tcl_NewWideIntObj.3.* 
    rm -f Tcl_SetIntObj.3 Tcl_SetIntObj.3.* 
    rm -f Tcl_SetLongObj.3 Tcl_SetLongObj.3.* 
    rm -f Tcl_SetWideIntObj.3 Tcl_SetWideIntObj.3.* 
    rm -f Tcl_GetIntFromObj.3 Tcl_GetIntFromObj.3.* 
    rm -f Tcl_GetLongFromObj.3 Tcl_GetLongFromObj.3.* 
    rm -f Tcl_GetWideIntFromObj.3 Tcl_GetWideIntFromObj.3.* 
    ln $S IntObj.3$Z Tcl_NewIntObj.3$Z 
    ln $S IntObj.3$Z Tcl_NewLongObj.3$Z 
    ln $S IntObj.3$Z Tcl_NewWideIntObj.3$Z 
    ln $S IntObj.3$Z Tcl_SetIntObj.3$Z 
    ln $S IntObj.3$Z Tcl_SetLongObj.3$Z 
    ln $S IntObj.3$Z Tcl_SetWideIntObj.3$Z 
    ln $S IntObj.3$Z Tcl_GetIntFromObj.3$Z 
    ln $S IntObj.3$Z Tcl_GetLongFromObj.3$Z 
    ln $S IntObj.3$Z Tcl_GetWideIntFromObj.3$Z 
fi
if test -r Interp.3; then
    rm -f Interp.3.*
    $ZIP Interp.3
    rm -f Tcl_Interp.3 Tcl_Interp.3.* 
    ln $S Interp.3$Z Tcl_Interp.3$Z 
fi
if test -r LinkVar.3; then
    rm -f LinkVar.3.*
    $ZIP LinkVar.3
    rm -f Tcl_LinkVar.3 Tcl_LinkVar.3.* 
    rm -f Tcl_UnlinkVar.3 Tcl_UnlinkVar.3.* 
    rm -f Tcl_UpdateLinkedVar.3 Tcl_UpdateLinkedVar.3.* 
    ln $S LinkVar.3$Z Tcl_LinkVar.3$Z 
    ln $S LinkVar.3$Z Tcl_UnlinkVar.3$Z 
    ln $S LinkVar.3$Z Tcl_UpdateLinkedVar.3$Z 
fi
if test -r ListObj.3; then
    rm -f ListObj.3.*
    $ZIP ListObj.3
    rm -f Tcl_ListObjAppendList.3 Tcl_ListObjAppendList.3.* 
    rm -f Tcl_ListObjAppendElement.3 Tcl_ListObjAppendElement.3.* 
    rm -f Tcl_NewListObj.3 Tcl_NewListObj.3.* 
    rm -f Tcl_SetListObj.3 Tcl_SetListObj.3.* 
    rm -f Tcl_ListObjGetElements.3 Tcl_ListObjGetElements.3.* 
    rm -f Tcl_ListObjLength.3 Tcl_ListObjLength.3.* 
    rm -f Tcl_ListObjIndex.3 Tcl_ListObjIndex.3.* 
    rm -f Tcl_ListObjReplace.3 Tcl_ListObjReplace.3.* 
    ln $S ListObj.3$Z Tcl_ListObjAppendList.3$Z 
    ln $S ListObj.3$Z Tcl_ListObjAppendElement.3$Z 
    ln $S ListObj.3$Z Tcl_NewListObj.3$Z 
    ln $S ListObj.3$Z Tcl_SetListObj.3$Z 
    ln $S ListObj.3$Z Tcl_ListObjGetElements.3$Z 
    ln $S ListObj.3$Z Tcl_ListObjLength.3$Z 
    ln $S ListObj.3$Z Tcl_ListObjIndex.3$Z 
    ln $S ListObj.3$Z Tcl_ListObjReplace.3$Z 
fi
if test -r Macintosh.3; then
    rm -f Macintosh.3.*
    $ZIP Macintosh.3
    rm -f Tcl_MacSetEventProc.3 Tcl_MacSetEventProc.3.* 
    rm -f Tcl_MacConvertTextResource.3 Tcl_MacConvertTextResource.3.* 
    rm -f Tcl_MacEvalResource.3 Tcl_MacEvalResource.3.* 
    rm -f Tcl_MacFindResource.3 Tcl_MacFindResource.3.* 
    rm -f Tcl_GetOSTypeFromObj.3 Tcl_GetOSTypeFromObj.3.* 
    rm -f Tcl_SetOSTypeObj.3 Tcl_SetOSTypeObj.3.* 
    rm -f Tcl_NewOSTypeObj.3 Tcl_NewOSTypeObj.3.* 
    ln $S Macintosh.3$Z Tcl_MacSetEventProc.3$Z 
    ln $S Macintosh.3$Z Tcl_MacConvertTextResource.3$Z 
    ln $S Macintosh.3$Z Tcl_MacEvalResource.3$Z 
    ln $S Macintosh.3$Z Tcl_MacFindResource.3$Z 
    ln $S Macintosh.3$Z Tcl_GetOSTypeFromObj.3$Z 
    ln $S Macintosh.3$Z Tcl_SetOSTypeObj.3$Z 
    ln $S Macintosh.3$Z Tcl_NewOSTypeObj.3$Z 
fi
if test -r Notifier.3; then
    rm -f Notifier.3.*
    $ZIP Notifier.3
    rm -f Tcl_CreateEventSource.3 Tcl_CreateEventSource.3.* 
    rm -f Tcl_DeleteEventSource.3 Tcl_DeleteEventSource.3.* 
    rm -f Tcl_SetMaxBlockTime.3 Tcl_SetMaxBlockTime.3.* 
    rm -f Tcl_QueueEvent.3 Tcl_QueueEvent.3.* 
    rm -f Tcl_ThreadQueueEvent.3 Tcl_ThreadQueueEvent.3.* 
    rm -f Tcl_ThreadAlert.3 Tcl_ThreadAlert.3.* 
    rm -f Tcl_GetCurrentThread.3 Tcl_GetCurrentThread.3.* 
    rm -f Tcl_DeleteEvents.3 Tcl_DeleteEvents.3.* 
    rm -f Tcl_InitNotifier.3 Tcl_InitNotifier.3.* 
    rm -f Tcl_FinalizeNotifier.3 Tcl_FinalizeNotifier.3.* 
    rm -f Tcl_WaitForEvent.3 Tcl_WaitForEvent.3.* 
    rm -f Tcl_AlertNotifier.3 Tcl_AlertNotifier.3.* 
    rm -f Tcl_SetTimer.3 Tcl_SetTimer.3.* 
    rm -f Tcl_ServiceAll.3 Tcl_ServiceAll.3.* 
    rm -f Tcl_ServiceEvent.3 Tcl_ServiceEvent.3.* 
    rm -f Tcl_GetServiceMode.3 Tcl_GetServiceMode.3.* 
    rm -f Tcl_SetServiceMode.3 Tcl_SetServiceMode.3.* 
    ln $S Notifier.3$Z Tcl_CreateEventSource.3$Z 
    ln $S Notifier.3$Z Tcl_DeleteEventSource.3$Z 
    ln $S Notifier.3$Z Tcl_SetMaxBlockTime.3$Z 
    ln $S Notifier.3$Z Tcl_QueueEvent.3$Z 
    ln $S Notifier.3$Z Tcl_ThreadQueueEvent.3$Z 
    ln $S Notifier.3$Z Tcl_ThreadAlert.3$Z 
    ln $S Notifier.3$Z Tcl_GetCurrentThread.3$Z 
    ln $S Notifier.3$Z Tcl_DeleteEvents.3$Z 
    ln $S Notifier.3$Z Tcl_InitNotifier.3$Z 
    ln $S Notifier.3$Z Tcl_FinalizeNotifier.3$Z 
    ln $S Notifier.3$Z Tcl_WaitForEvent.3$Z 
    ln $S Notifier.3$Z Tcl_AlertNotifier.3$Z 
    ln $S Notifier.3$Z Tcl_SetTimer.3$Z 
    ln $S Notifier.3$Z Tcl_ServiceAll.3$Z 
    ln $S Notifier.3$Z Tcl_ServiceEvent.3$Z 
    ln $S Notifier.3$Z Tcl_GetServiceMode.3$Z 
    ln $S Notifier.3$Z Tcl_SetServiceMode.3$Z 
fi
if test -r Object.3; then
    rm -f Object.3.*
    $ZIP Object.3
    rm -f Tcl_NewObj.3 Tcl_NewObj.3.* 
    rm -f Tcl_DuplicateObj.3 Tcl_DuplicateObj.3.* 
    rm -f Tcl_IncrRefCount.3 Tcl_IncrRefCount.3.* 
    rm -f Tcl_DecrRefCount.3 Tcl_DecrRefCount.3.* 
    rm -f Tcl_IsShared.3 Tcl_IsShared.3.* 
    rm -f Tcl_InvalidateStringRep.3 Tcl_InvalidateStringRep.3.* 
    ln $S Object.3$Z Tcl_NewObj.3$Z 
    ln $S Object.3$Z Tcl_DuplicateObj.3$Z 
    ln $S Object.3$Z Tcl_IncrRefCount.3$Z 
    ln $S Object.3$Z Tcl_DecrRefCount.3$Z 
    ln $S Object.3$Z Tcl_IsShared.3$Z 
    ln $S Object.3$Z Tcl_InvalidateStringRep.3$Z 
fi
if test -r ObjectType.3; then
    rm -f ObjectType.3.*
    $ZIP ObjectType.3
    rm -f Tcl_RegisterObjType.3 Tcl_RegisterObjType.3.* 
    rm -f Tcl_GetObjType.3 Tcl_GetObjType.3.* 
    rm -f Tcl_AppendAllObjTypes.3 Tcl_AppendAllObjTypes.3.* 
    rm -f Tcl_ConvertToType.3 Tcl_ConvertToType.3.* 
    ln $S ObjectType.3$Z Tcl_RegisterObjType.3$Z 
    ln $S ObjectType.3$Z Tcl_GetObjType.3$Z 
    ln $S ObjectType.3$Z Tcl_AppendAllObjTypes.3$Z 
    ln $S ObjectType.3$Z Tcl_ConvertToType.3$Z 
fi
if test -r OpenFileChnl.3; then
    rm -f OpenFileChnl.3.*
    $ZIP OpenFileChnl.3
    rm -f Tcl_OpenFileChannel.3 Tcl_OpenFileChannel.3.* 
    rm -f Tcl_OpenCommandChannel.3 Tcl_OpenCommandChannel.3.* 
    rm -f Tcl_MakeFileChannel.3 Tcl_MakeFileChannel.3.* 
    rm -f Tcl_GetChannel.3 Tcl_GetChannel.3.* 
    rm -f Tcl_GetChannelNames.3 Tcl_GetChannelNames.3.* 
    rm -f Tcl_GetChannelNamesEx.3 Tcl_GetChannelNamesEx.3.* 
    rm -f Tcl_RegisterChannel.3 Tcl_RegisterChannel.3.* 
    rm -f Tcl_UnregisterChannel.3 Tcl_UnregisterChannel.3.* 
    rm -f Tcl_DetachChannel.3 Tcl_DetachChannel.3.* 
    rm -f Tcl_IsStandardChannel.3 Tcl_IsStandardChannel.3.* 
    rm -f Tcl_Close.3 Tcl_Close.3.* 
    rm -f Tcl_ReadChars.3 Tcl_ReadChars.3.* 
    rm -f Tcl_Read.3 Tcl_Read.3.* 
    rm -f Tcl_GetsObj.3 Tcl_GetsObj.3.* 
    rm -f Tcl_Gets.3 Tcl_Gets.3.* 
    rm -f Tcl_WriteObj.3 Tcl_WriteObj.3.* 
    rm -f Tcl_WriteChars.3 Tcl_WriteChars.3.* 
    rm -f Tcl_Write.3 Tcl_Write.3.* 
    rm -f Tcl_Flush.3 Tcl_Flush.3.* 
    rm -f Tcl_Seek.3 Tcl_Seek.3.* 
    rm -f Tcl_Tell.3 Tcl_Tell.3.* 
    rm -f Tcl_GetChannelOption.3 Tcl_GetChannelOption.3.* 
    rm -f Tcl_SetChannelOption.3 Tcl_SetChannelOption.3.* 
    rm -f Tcl_Eof.3 Tcl_Eof.3.* 
    rm -f Tcl_InputBlocked.3 Tcl_InputBlocked.3.* 
    rm -f Tcl_InputBuffered.3 Tcl_InputBuffered.3.* 
    rm -f Tcl_OutputBuffered.3 Tcl_OutputBuffered.3.* 
    rm -f Tcl_Ungets.3 Tcl_Ungets.3.* 
    rm -f Tcl_ReadRaw.3 Tcl_ReadRaw.3.* 
    rm -f Tcl_WriteRaw.3 Tcl_WriteRaw.3.* 
    ln $S OpenFileChnl.3$Z Tcl_OpenFileChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_OpenCommandChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_MakeFileChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_GetChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_GetChannelNames.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_GetChannelNamesEx.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_RegisterChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_UnregisterChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_DetachChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_IsStandardChannel.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Close.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_ReadChars.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Read.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_GetsObj.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Gets.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_WriteObj.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_WriteChars.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Write.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Flush.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Seek.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Tell.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_GetChannelOption.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_SetChannelOption.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Eof.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_InputBlocked.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_InputBuffered.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_OutputBuffered.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_Ungets.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_ReadRaw.3$Z 
    ln $S OpenFileChnl.3$Z Tcl_WriteRaw.3$Z 
fi
if test -r OpenTcp.3; then
    rm -f OpenTcp.3.*
    $ZIP OpenTcp.3
    rm -f Tcl_OpenTcpClient.3 Tcl_OpenTcpClient.3.* 
    rm -f Tcl_MakeTcpClientChannel.3 Tcl_MakeTcpClientChannel.3.* 
    rm -f Tcl_OpenTcpServer.3 Tcl_OpenTcpServer.3.* 
    ln $S OpenTcp.3$Z Tcl_OpenTcpClient.3$Z 
    ln $S OpenTcp.3$Z Tcl_MakeTcpClientChannel.3$Z 
    ln $S OpenTcp.3$Z Tcl_OpenTcpServer.3$Z 
fi
if test -r Panic.3; then
    rm -f Panic.3.*
    $ZIP Panic.3
    rm -f Tcl_Panic.3 Tcl_Panic.3.* 
    rm -f Tcl_PanicVA.3 Tcl_PanicVA.3.* 
    rm -f Tcl_SetPanicProc.3 Tcl_SetPanicProc.3.* 
    if test "${CASEINSENSITIVEFS:-}" != "1"; then rm -f panic.3 panic.3.* ; fi
    rm -f panicVA.3 panicVA.3.* 
    ln $S Panic.3$Z Tcl_Panic.3$Z 
    ln $S Panic.3$Z Tcl_PanicVA.3$Z 
    ln $S Panic.3$Z Tcl_SetPanicProc.3$Z 
    if test "${CASEINSENSITIVEFS:-}" != "1"; then ln $S Panic.3$Z panic.3$Z ; fi
    ln $S Panic.3$Z panicVA.3$Z 
fi
if test -r ParseCmd.3; then
    rm -f ParseCmd.3.*
    $ZIP ParseCmd.3
    rm -f Tcl_ParseCommand.3 Tcl_ParseCommand.3.* 
    rm -f Tcl_ParseExpr.3 Tcl_ParseExpr.3.* 
    rm -f Tcl_ParseBraces.3 Tcl_ParseBraces.3.* 
    rm -f Tcl_ParseQuotedString.3 Tcl_ParseQuotedString.3.* 
    rm -f Tcl_ParseVarName.3 Tcl_ParseVarName.3.* 
    rm -f Tcl_ParseVar.3 Tcl_ParseVar.3.* 
    rm -f Tcl_FreeParse.3 Tcl_FreeParse.3.* 
    rm -f Tcl_EvalTokens.3 Tcl_EvalTokens.3.* 
    rm -f Tcl_EvalTokensStandard.3 Tcl_EvalTokensStandard.3.* 
    ln $S ParseCmd.3$Z Tcl_ParseCommand.3$Z 
    ln $S ParseCmd.3$Z Tcl_ParseExpr.3$Z 
    ln $S ParseCmd.3$Z Tcl_ParseBraces.3$Z 
    ln $S ParseCmd.3$Z Tcl_ParseQuotedString.3$Z 
    ln $S ParseCmd.3$Z Tcl_ParseVarName.3$Z 
    ln $S ParseCmd.3$Z Tcl_ParseVar.3$Z 
    ln $S ParseCmd.3$Z Tcl_FreeParse.3$Z 
    ln $S ParseCmd.3$Z Tcl_EvalTokens.3$Z 
    ln $S ParseCmd.3$Z Tcl_EvalTokensStandard.3$Z 
fi
if test -r PkgRequire.3; then
    rm -f PkgRequire.3.*
    $ZIP PkgRequire.3
    rm -f Tcl_PkgRequire.3 Tcl_PkgRequire.3.* 
    rm -f Tcl_PkgRequireEx.3 Tcl_PkgRequireEx.3.* 
    rm -f Tcl_PkgPresent.3 Tcl_PkgPresent.3.* 
    rm -f Tcl_PkgPresentEx.3 Tcl_PkgPresentEx.3.* 
    rm -f Tcl_PkgProvide.3 Tcl_PkgProvide.3.* 
    rm -f Tcl_PkgProvideEx.3 Tcl_PkgProvideEx.3.* 
    ln $S PkgRequire.3$Z Tcl_PkgRequire.3$Z 
    ln $S PkgRequire.3$Z Tcl_PkgRequireEx.3$Z 
    ln $S PkgRequire.3$Z Tcl_PkgPresent.3$Z 
    ln $S PkgRequire.3$Z Tcl_PkgPresentEx.3$Z 
    ln $S PkgRequire.3$Z Tcl_PkgProvide.3$Z 
    ln $S PkgRequire.3$Z Tcl_PkgProvideEx.3$Z 
fi
if test -r Preserve.3; then
    rm -f Preserve.3.*
    $ZIP Preserve.3
    rm -f Tcl_Preserve.3 Tcl_Preserve.3.* 
    rm -f Tcl_Release.3 Tcl_Release.3.* 
    rm -f Tcl_EventuallyFree.3 Tcl_EventuallyFree.3.* 
    ln $S Preserve.3$Z Tcl_Preserve.3$Z 
    ln $S Preserve.3$Z Tcl_Release.3$Z 
    ln $S Preserve.3$Z Tcl_EventuallyFree.3$Z 
fi
if test -r PrintDbl.3; then
    rm -f PrintDbl.3.*
    $ZIP PrintDbl.3
    rm -f Tcl_PrintDouble.3 Tcl_PrintDouble.3.* 
    ln $S PrintDbl.3$Z Tcl_PrintDouble.3$Z 
fi
if test -r RecEvalObj.3; then
    rm -f RecEvalObj.3.*
    $ZIP RecEvalObj.3
    rm -f Tcl_RecordAndEvalObj.3 Tcl_RecordAndEvalObj.3.* 
    ln $S RecEvalObj.3$Z Tcl_RecordAndEvalObj.3$Z 
fi
if test -r RecordEval.3; then
    rm -f RecordEval.3.*
    $ZIP RecordEval.3
    rm -f Tcl_RecordAndEval.3 Tcl_RecordAndEval.3.* 
    ln $S RecordEval.3$Z Tcl_RecordAndEval.3$Z 
fi
if test -r RegExp.3; then
    rm -f RegExp.3.*
    $ZIP RegExp.3
    rm -f Tcl_RegExpMatch.3 Tcl_RegExpMatch.3.* 
    rm -f Tcl_RegExpCompile.3 Tcl_RegExpCompile.3.* 
    rm -f Tcl_RegExpExec.3 Tcl_RegExpExec.3.* 
    rm -f Tcl_RegExpRange.3 Tcl_RegExpRange.3.* 
    rm -f Tcl_GetRegExpFromObj.3 Tcl_GetRegExpFromObj.3.* 
    rm -f Tcl_RegExpMatchObj.3 Tcl_RegExpMatchObj.3.* 
    rm -f Tcl_RegExpExecObj.3 Tcl_RegExpExecObj.3.* 
    rm -f Tcl_RegExpGetInfo.3 Tcl_RegExpGetInfo.3.* 
    ln $S RegExp.3$Z Tcl_RegExpMatch.3$Z 
    ln $S RegExp.3$Z Tcl_RegExpCompile.3$Z 
    ln $S RegExp.3$Z Tcl_RegExpExec.3$Z 
    ln $S RegExp.3$Z Tcl_RegExpRange.3$Z 
    ln $S RegExp.3$Z Tcl_GetRegExpFromObj.3$Z 
    ln $S RegExp.3$Z Tcl_RegExpMatchObj.3$Z 
    ln $S RegExp.3$Z Tcl_RegExpExecObj.3$Z 
    ln $S RegExp.3$Z Tcl_RegExpGetInfo.3$Z 
fi
if test -r SaveResult.3; then
    rm -f SaveResult.3.*
    $ZIP SaveResult.3
    rm -f Tcl_SaveResult.3 Tcl_SaveResult.3.* 
    rm -f Tcl_RestoreResult.3 Tcl_RestoreResult.3.* 
    rm -f Tcl_DiscardResult.3 Tcl_DiscardResult.3.* 
    ln $S SaveResult.3$Z Tcl_SaveResult.3$Z 
    ln $S SaveResult.3$Z Tcl_RestoreResult.3$Z 
    ln $S SaveResult.3$Z Tcl_DiscardResult.3$Z 
fi
if test -r SetErrno.3; then
    rm -f SetErrno.3.*
    $ZIP SetErrno.3
    rm -f Tcl_SetErrno.3 Tcl_SetErrno.3.* 
    rm -f Tcl_GetErrno.3 Tcl_GetErrno.3.* 
    rm -f Tcl_ErrnoId.3 Tcl_ErrnoId.3.* 
    rm -f Tcl_ErrnoMsg.3 Tcl_ErrnoMsg.3.* 
    ln $S SetErrno.3$Z Tcl_SetErrno.3$Z 
    ln $S SetErrno.3$Z Tcl_GetErrno.3$Z 
    ln $S SetErrno.3$Z Tcl_ErrnoId.3$Z 
    ln $S SetErrno.3$Z Tcl_ErrnoMsg.3$Z 
fi
if test -r SetRecLmt.3; then
    rm -f SetRecLmt.3.*
    $ZIP SetRecLmt.3
    rm -f Tcl_SetRecursionLimit.3 Tcl_SetRecursionLimit.3.* 
    ln $S SetRecLmt.3$Z Tcl_SetRecursionLimit.3$Z 
fi
if test -r SetResult.3; then
    rm -f SetResult.3.*
    $ZIP SetResult.3
    rm -f Tcl_SetObjResult.3 Tcl_SetObjResult.3.* 
    rm -f Tcl_GetObjResult.3 Tcl_GetObjResult.3.* 
    rm -f Tcl_SetResult.3 Tcl_SetResult.3.* 
    rm -f Tcl_GetStringResult.3 Tcl_GetStringResult.3.* 
    rm -f Tcl_AppendResult.3 Tcl_AppendResult.3.* 
    rm -f Tcl_AppendResultVA.3 Tcl_AppendResultVA.3.* 
    rm -f Tcl_AppendElement.3 Tcl_AppendElement.3.* 
    rm -f Tcl_ResetResult.3 Tcl_ResetResult.3.* 
    rm -f Tcl_FreeResult.3 Tcl_FreeResult.3.* 
    ln $S SetResult.3$Z Tcl_SetObjResult.3$Z 
    ln $S SetResult.3$Z Tcl_GetObjResult.3$Z 
    ln $S SetResult.3$Z Tcl_SetResult.3$Z 
    ln $S SetResult.3$Z Tcl_GetStringResult.3$Z 
    ln $S SetResult.3$Z Tcl_AppendResult.3$Z 
    ln $S SetResult.3$Z Tcl_AppendResultVA.3$Z 
    ln $S SetResult.3$Z Tcl_AppendElement.3$Z 
    ln $S SetResult.3$Z Tcl_ResetResult.3$Z 
    ln $S SetResult.3$Z Tcl_FreeResult.3$Z 
fi
if test -r SetVar.3; then
    rm -f SetVar.3.*
    $ZIP SetVar.3
    rm -f Tcl_SetVar2Ex.3 Tcl_SetVar2Ex.3.* 
    rm -f Tcl_SetVar.3 Tcl_SetVar.3.* 
    rm -f Tcl_SetVar2.3 Tcl_SetVar2.3.* 
    rm -f Tcl_ObjSetVar2.3 Tcl_ObjSetVar2.3.* 
    rm -f Tcl_GetVar2Ex.3 Tcl_GetVar2Ex.3.* 
    rm -f Tcl_GetVar.3 Tcl_GetVar.3.* 
    rm -f Tcl_GetVar2.3 Tcl_GetVar2.3.* 
    rm -f Tcl_ObjGetVar2.3 Tcl_ObjGetVar2.3.* 
    rm -f Tcl_UnsetVar.3 Tcl_UnsetVar.3.* 
    rm -f Tcl_UnsetVar2.3 Tcl_UnsetVar2.3.* 
    ln $S SetVar.3$Z Tcl_SetVar2Ex.3$Z 
    ln $S SetVar.3$Z Tcl_SetVar.3$Z 
    ln $S SetVar.3$Z Tcl_SetVar2.3$Z 
    ln $S SetVar.3$Z Tcl_ObjSetVar2.3$Z 
    ln $S SetVar.3$Z Tcl_GetVar2Ex.3$Z 
    ln $S SetVar.3$Z Tcl_GetVar.3$Z 
    ln $S SetVar.3$Z Tcl_GetVar2.3$Z 
    ln $S SetVar.3$Z Tcl_ObjGetVar2.3$Z 
    ln $S SetVar.3$Z Tcl_UnsetVar.3$Z 
    ln $S SetVar.3$Z Tcl_UnsetVar2.3$Z 
fi
if test -r Signal.3; then
    rm -f Signal.3.*
    $ZIP Signal.3
    rm -f Tcl_SignalId.3 Tcl_SignalId.3.* 
    rm -f Tcl_SignalMsg.3 Tcl_SignalMsg.3.* 
    ln $S Signal.3$Z Tcl_SignalId.3$Z 
    ln $S Signal.3$Z Tcl_SignalMsg.3$Z 
fi
if test -r Sleep.3; then
    rm -f Sleep.3.*
    $ZIP Sleep.3
    rm -f Tcl_Sleep.3 Tcl_Sleep.3.* 
    ln $S Sleep.3$Z Tcl_Sleep.3$Z 
fi
if test -r SourceRCFile.3; then
    rm -f SourceRCFile.3.*
    $ZIP SourceRCFile.3
    rm -f Tcl_SourceRCFile.3 Tcl_SourceRCFile.3.* 
    ln $S SourceRCFile.3$Z Tcl_SourceRCFile.3$Z 
fi
if test -r SplitList.3; then
    rm -f SplitList.3.*
    $ZIP SplitList.3
    rm -f Tcl_SplitList.3 Tcl_SplitList.3.* 
    rm -f Tcl_Merge.3 Tcl_Merge.3.* 
    rm -f Tcl_ScanElement.3 Tcl_ScanElement.3.* 
    rm -f Tcl_ConvertElement.3 Tcl_ConvertElement.3.* 
    rm -f Tcl_ScanCountedElement.3 Tcl_ScanCountedElement.3.* 
    rm -f Tcl_ConvertCountedElement.3 Tcl_ConvertCountedElement.3.* 
    ln $S SplitList.3$Z Tcl_SplitList.3$Z 
    ln $S SplitList.3$Z Tcl_Merge.3$Z 
    ln $S SplitList.3$Z Tcl_ScanElement.3$Z 
    ln $S SplitList.3$Z Tcl_ConvertElement.3$Z 
    ln $S SplitList.3$Z Tcl_ScanCountedElement.3$Z 
    ln $S SplitList.3$Z Tcl_ConvertCountedElement.3$Z 
fi
if test -r SplitPath.3; then
    rm -f SplitPath.3.*
    $ZIP SplitPath.3
    rm -f Tcl_SplitPath.3 Tcl_SplitPath.3.* 
    rm -f Tcl_JoinPath.3 Tcl_JoinPath.3.* 
    rm -f Tcl_GetPathType.3 Tcl_GetPathType.3.* 
    ln $S SplitPath.3$Z Tcl_SplitPath.3$Z 
    ln $S SplitPath.3$Z Tcl_JoinPath.3$Z 
    ln $S SplitPath.3$Z Tcl_GetPathType.3$Z 
fi
if test -r StaticPkg.3; then
    rm -f StaticPkg.3.*
    $ZIP StaticPkg.3
    rm -f Tcl_StaticPackage.3 Tcl_StaticPackage.3.* 
    ln $S StaticPkg.3$Z Tcl_StaticPackage.3$Z 
fi
if test -r StdChannels.3; then
    rm -f StdChannels.3.*
    $ZIP StdChannels.3
    rm -f Tcl_StandardChannels.3 Tcl_StandardChannels.3.* 
    ln $S StdChannels.3$Z Tcl_StandardChannels.3$Z 
fi
if test -r StrMatch.3; then
    rm -f StrMatch.3.*
    $ZIP StrMatch.3
    rm -f Tcl_StringMatch.3 Tcl_StringMatch.3.* 
    rm -f Tcl_StringCaseMatch.3 Tcl_StringCaseMatch.3.* 
    ln $S StrMatch.3$Z Tcl_StringMatch.3$Z 
    ln $S StrMatch.3$Z Tcl_StringCaseMatch.3$Z 
fi
if test -r StringObj.3; then
    rm -f StringObj.3.*
    $ZIP StringObj.3
    rm -f Tcl_NewStringObj.3 Tcl_NewStringObj.3.* 
    rm -f Tcl_NewUnicodeObj.3 Tcl_NewUnicodeObj.3.* 
    rm -f Tcl_SetStringObj.3 Tcl_SetStringObj.3.* 
    rm -f Tcl_SetUnicodeObj.3 Tcl_SetUnicodeObj.3.* 
    rm -f Tcl_GetStringFromObj.3 Tcl_GetStringFromObj.3.* 
    rm -f Tcl_GetString.3 Tcl_GetString.3.* 
    rm -f Tcl_GetUnicodeFromObj.3 Tcl_GetUnicodeFromObj.3.* 
    rm -f Tcl_GetUnicode.3 Tcl_GetUnicode.3.* 
    rm -f Tcl_GetUniChar.3 Tcl_GetUniChar.3.* 
    rm -f Tcl_GetCharLength.3 Tcl_GetCharLength.3.* 
    rm -f Tcl_GetRange.3 Tcl_GetRange.3.* 
    rm -f Tcl_AppendToObj.3 Tcl_AppendToObj.3.* 
    rm -f Tcl_AppendUnicodeToObj.3 Tcl_AppendUnicodeToObj.3.* 
    rm -f Tcl_AppendStringsToObj.3 Tcl_AppendStringsToObj.3.* 
    rm -f Tcl_AppendStringsToObjVA.3 Tcl_AppendStringsToObjVA.3.* 
    rm -f Tcl_AppendObjToObj.3 Tcl_AppendObjToObj.3.* 
    rm -f Tcl_SetObjLength.3 Tcl_SetObjLength.3.* 
    rm -f Tcl_ConcatObj.3 Tcl_ConcatObj.3.* 
    rm -f Tcl_AttemptSetObjLength.3 Tcl_AttemptSetObjLength.3.* 
    ln $S StringObj.3$Z Tcl_NewStringObj.3$Z 
    ln $S StringObj.3$Z Tcl_NewUnicodeObj.3$Z 
    ln $S StringObj.3$Z Tcl_SetStringObj.3$Z 
    ln $S StringObj.3$Z Tcl_SetUnicodeObj.3$Z 
    ln $S StringObj.3$Z Tcl_GetStringFromObj.3$Z 
    ln $S StringObj.3$Z Tcl_GetString.3$Z 
    ln $S StringObj.3$Z Tcl_GetUnicodeFromObj.3$Z 
    ln $S StringObj.3$Z Tcl_GetUnicode.3$Z 
    ln $S StringObj.3$Z Tcl_GetUniChar.3$Z 
    ln $S StringObj.3$Z Tcl_GetCharLength.3$Z 
    ln $S StringObj.3$Z Tcl_GetRange.3$Z 
    ln $S StringObj.3$Z Tcl_AppendToObj.3$Z 
    ln $S StringObj.3$Z Tcl_AppendUnicodeToObj.3$Z 
    ln $S StringObj.3$Z Tcl_AppendStringsToObj.3$Z 
    ln $S StringObj.3$Z Tcl_AppendStringsToObjVA.3$Z 
    ln $S StringObj.3$Z Tcl_AppendObjToObj.3$Z 
    ln $S StringObj.3$Z Tcl_SetObjLength.3$Z 
    ln $S StringObj.3$Z Tcl_ConcatObj.3$Z 
    ln $S StringObj.3$Z Tcl_AttemptSetObjLength.3$Z 
fi
if test -r SubstObj.3; then
    rm -f SubstObj.3.*
    $ZIP SubstObj.3
    rm -f Tcl_SubstObj.3 Tcl_SubstObj.3.* 
    ln $S SubstObj.3$Z Tcl_SubstObj.3$Z 
fi
if test -r TCL_MEM_DEBUG.3; then
    rm -f TCL_MEM_DEBUG.3.*
    $ZIP TCL_MEM_DEBUG.3
fi
if test -r Tcl.n; then
    rm -f Tcl.n.*
    $ZIP Tcl.n
fi
if test -r Tcl_Main.3; then
    rm -f Tcl_Main.3.*
    $ZIP Tcl_Main.3
    rm -f Tcl_SetMainLoop.3 Tcl_SetMainLoop.3.* 
    ln $S Tcl_Main.3$Z Tcl_SetMainLoop.3$Z 
fi
if test -r Thread.3; then
    rm -f Thread.3.*
    $ZIP Thread.3
    rm -f Tcl_ConditionNotify.3 Tcl_ConditionNotify.3.* 
    rm -f Tcl_ConditionWait.3 Tcl_ConditionWait.3.* 
    rm -f Tcl_ConditionFinalize.3 Tcl_ConditionFinalize.3.* 
    rm -f Tcl_GetThreadData.3 Tcl_GetThreadData.3.* 
    rm -f Tcl_MutexLock.3 Tcl_MutexLock.3.* 
    rm -f Tcl_MutexUnlock.3 Tcl_MutexUnlock.3.* 
    rm -f Tcl_MutexFinalize.3 Tcl_MutexFinalize.3.* 
    rm -f Tcl_CreateThread.3 Tcl_CreateThread.3.* 
    rm -f Tcl_JoinThread.3 Tcl_JoinThread.3.* 
    ln $S Thread.3$Z Tcl_ConditionNotify.3$Z 
    ln $S Thread.3$Z Tcl_ConditionWait.3$Z 
    ln $S Thread.3$Z Tcl_ConditionFinalize.3$Z 
    ln $S Thread.3$Z Tcl_GetThreadData.3$Z 
    ln $S Thread.3$Z Tcl_MutexLock.3$Z 
    ln $S Thread.3$Z Tcl_MutexUnlock.3$Z 
    ln $S Thread.3$Z Tcl_MutexFinalize.3$Z 
    ln $S Thread.3$Z Tcl_CreateThread.3$Z 
    ln $S Thread.3$Z Tcl_JoinThread.3$Z 
fi
if test -r ToUpper.3; then
    rm -f ToUpper.3.*
    $ZIP ToUpper.3
    rm -f Tcl_UniCharToUpper.3 Tcl_UniCharToUpper.3.* 
    rm -f Tcl_UniCharToLower.3 Tcl_UniCharToLower.3.* 
    rm -f Tcl_UniCharToTitle.3 Tcl_UniCharToTitle.3.* 
    rm -f Tcl_UtfToUpper.3 Tcl_UtfToUpper.3.* 
    rm -f Tcl_UtfToLower.3 Tcl_UtfToLower.3.* 
    rm -f Tcl_UtfToTitle.3 Tcl_UtfToTitle.3.* 
    ln $S ToUpper.3$Z Tcl_UniCharToUpper.3$Z 
    ln $S ToUpper.3$Z Tcl_UniCharToLower.3$Z 
    ln $S ToUpper.3$Z Tcl_UniCharToTitle.3$Z 
    ln $S ToUpper.3$Z Tcl_UtfToUpper.3$Z 
    ln $S ToUpper.3$Z Tcl_UtfToLower.3$Z 
    ln $S ToUpper.3$Z Tcl_UtfToTitle.3$Z 
fi
if test -r TraceCmd.3; then
    rm -f TraceCmd.3.*
    $ZIP TraceCmd.3
    rm -f Tcl_CommandTraceInfo.3 Tcl_CommandTraceInfo.3.* 
    rm -f Tcl_TraceCommand.3 Tcl_TraceCommand.3.* 
    rm -f Tcl_UntraceCommand.3 Tcl_UntraceCommand.3.* 
    ln $S TraceCmd.3$Z Tcl_CommandTraceInfo.3$Z 
    ln $S TraceCmd.3$Z Tcl_TraceCommand.3$Z 
    ln $S TraceCmd.3$Z Tcl_UntraceCommand.3$Z 
fi
if test -r TraceVar.3; then
    rm -f TraceVar.3.*
    $ZIP TraceVar.3
    rm -f Tcl_TraceVar.3 Tcl_TraceVar.3.* 
    rm -f Tcl_TraceVar2.3 Tcl_TraceVar2.3.* 
    rm -f Tcl_UntraceVar.3 Tcl_UntraceVar.3.* 
    rm -f Tcl_UntraceVar2.3 Tcl_UntraceVar2.3.* 
    rm -f Tcl_VarTraceInfo.3 Tcl_VarTraceInfo.3.* 
    rm -f Tcl_VarTraceInfo2.3 Tcl_VarTraceInfo2.3.* 
    ln $S TraceVar.3$Z Tcl_TraceVar.3$Z 
    ln $S TraceVar.3$Z Tcl_TraceVar2.3$Z 
    ln $S TraceVar.3$Z Tcl_UntraceVar.3$Z 
    ln $S TraceVar.3$Z Tcl_UntraceVar2.3$Z 
    ln $S TraceVar.3$Z Tcl_VarTraceInfo.3$Z 
    ln $S TraceVar.3$Z Tcl_VarTraceInfo2.3$Z 
fi
if test -r Translate.3; then
    rm -f Translate.3.*
    $ZIP Translate.3
    rm -f Tcl_TranslateFileName.3 Tcl_TranslateFileName.3.* 
    ln $S Translate.3$Z Tcl_TranslateFileName.3$Z 
fi
if test -r UniCharIsAlpha.3; then
    rm -f UniCharIsAlpha.3.*
    $ZIP UniCharIsAlpha.3
    rm -f Tcl_UniCharIsAlnum.3 Tcl_UniCharIsAlnum.3.* 
    rm -f Tcl_UniCharIsAlpha.3 Tcl_UniCharIsAlpha.3.* 
    rm -f Tcl_UniCharIsControl.3 Tcl_UniCharIsControl.3.* 
    rm -f Tcl_UniCharIsDigit.3 Tcl_UniCharIsDigit.3.* 
    rm -f Tcl_UniCharIsGraph.3 Tcl_UniCharIsGraph.3.* 
    rm -f Tcl_UniCharIsLower.3 Tcl_UniCharIsLower.3.* 
    rm -f Tcl_UniCharIsPrint.3 Tcl_UniCharIsPrint.3.* 
    rm -f Tcl_UniCharIsPunct.3 Tcl_UniCharIsPunct.3.* 
    rm -f Tcl_UniCharIsSpace.3 Tcl_UniCharIsSpace.3.* 
    rm -f Tcl_UniCharIsUpper.3 Tcl_UniCharIsUpper.3.* 
    rm -f Tcl_UniCharIsWordChar.3 Tcl_UniCharIsWordChar.3.* 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsAlnum.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsAlpha.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsControl.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsDigit.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsGraph.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsLower.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsPrint.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsPunct.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsSpace.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsUpper.3$Z 
    ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsWordChar.3$Z 
fi
if test -r UpVar.3; then
    rm -f UpVar.3.*
    $ZIP UpVar.3
    rm -f Tcl_UpVar.3 Tcl_UpVar.3.* 
    rm -f Tcl_UpVar2.3 Tcl_UpVar2.3.* 
    ln $S UpVar.3$Z Tcl_UpVar.3$Z 
    ln $S UpVar.3$Z Tcl_UpVar2.3$Z 
fi
if test -r Utf.3; then
    rm -f Utf.3.*
    $ZIP Utf.3
    rm -f Tcl_UniChar.3 Tcl_UniChar.3.* 
    rm -f Tcl_UniCharCaseMatch.3 Tcl_UniCharCaseMatch.3.* 
    rm -f Tcl_UniCharNcasecmp.3 Tcl_UniCharNcasecmp.3.* 
    rm -f Tcl_UniCharToUtf.3 Tcl_UniCharToUtf.3.* 
    rm -f Tcl_UtfToUniChar.3 Tcl_UtfToUniChar.3.* 
    rm -f Tcl_UniCharToUtfDString.3 Tcl_UniCharToUtfDString.3.* 
    rm -f Tcl_UtfToUniCharDString.3 Tcl_UtfToUniCharDString.3.* 
    rm -f Tcl_UniCharLen.3 Tcl_UniCharLen.3.* 
    rm -f Tcl_UniCharNcmp.3 Tcl_UniCharNcmp.3.* 
    rm -f Tcl_UtfCharComplete.3 Tcl_UtfCharComplete.3.* 
    rm -f Tcl_NumUtfChars.3 Tcl_NumUtfChars.3.* 
    rm -f Tcl_UtfFindFirst.3 Tcl_UtfFindFirst.3.* 
    rm -f Tcl_UtfFindLast.3 Tcl_UtfFindLast.3.* 
    rm -f Tcl_UtfNext.3 Tcl_UtfNext.3.* 
    rm -f Tcl_UtfPrev.3 Tcl_UtfPrev.3.* 
    rm -f Tcl_UniCharAtIndex.3 Tcl_UniCharAtIndex.3.* 
    rm -f Tcl_UtfAtIndex.3 Tcl_UtfAtIndex.3.* 
    rm -f Tcl_UtfBackslash.3 Tcl_UtfBackslash.3.* 
    ln $S Utf.3$Z Tcl_UniChar.3$Z 
    ln $S Utf.3$Z Tcl_UniCharCaseMatch.3$Z 
    ln $S Utf.3$Z Tcl_UniCharNcasecmp.3$Z 
    ln $S Utf.3$Z Tcl_UniCharToUtf.3$Z 
    ln $S Utf.3$Z Tcl_UtfToUniChar.3$Z 
    ln $S Utf.3$Z Tcl_UniCharToUtfDString.3$Z 
    ln $S Utf.3$Z Tcl_UtfToUniCharDString.3$Z 
    ln $S Utf.3$Z Tcl_UniCharLen.3$Z 
    ln $S Utf.3$Z Tcl_UniCharNcmp.3$Z 
    ln $S Utf.3$Z Tcl_UtfCharComplete.3$Z 
    ln $S Utf.3$Z Tcl_NumUtfChars.3$Z 
    ln $S Utf.3$Z Tcl_UtfFindFirst.3$Z 
    ln $S Utf.3$Z Tcl_UtfFindLast.3$Z 
    ln $S Utf.3$Z Tcl_UtfNext.3$Z 
    ln $S Utf.3$Z Tcl_UtfPrev.3$Z 
    ln $S Utf.3$Z Tcl_UniCharAtIndex.3$Z 
    ln $S Utf.3$Z Tcl_UtfAtIndex.3$Z 
    ln $S Utf.3$Z Tcl_UtfBackslash.3$Z 
fi
if test -r WrongNumArgs.3; then
    rm -f WrongNumArgs.3.*
    $ZIP WrongNumArgs.3
    rm -f Tcl_WrongNumArgs.3 Tcl_WrongNumArgs.3.* 
    ln $S WrongNumArgs.3$Z Tcl_WrongNumArgs.3$Z 
fi
if test -r after.n; then
    rm -f after.n.*
    $ZIP after.n
fi
if test -r append.n; then
    rm -f append.n.*
    $ZIP append.n
fi
if test -r array.n; then
    rm -f array.n.*
    $ZIP array.n
fi
if test -r bgerror.n; then
    rm -f bgerror.n.*
    $ZIP bgerror.n
fi
if test -r binary.n; then
    rm -f binary.n.*
    $ZIP binary.n
fi
if test -r break.n; then
    rm -f break.n.*
    $ZIP break.n
fi
if test -r case.n; then
    rm -f case.n.*
    $ZIP case.n
fi
if test -r catch.n; then
    rm -f catch.n.*
    $ZIP catch.n
fi
if test -r cd.n; then
    rm -f cd.n.*
    $ZIP cd.n
fi
if test -r clock.n; then
    rm -f clock.n.*
    $ZIP clock.n
fi
if test -r close.n; then
    rm -f close.n.*
    $ZIP close.n
fi
if test -r concat.n; then
    rm -f concat.n.*
    $ZIP concat.n
fi
if test -r continue.n; then
    rm -f continue.n.*
    $ZIP continue.n
fi
if test -r dde.n; then
    rm -f dde.n.*
    $ZIP dde.n
fi
if test -r encoding.n; then
    rm -f encoding.n.*
    $ZIP encoding.n
fi
if test -r eof.n; then
    rm -f eof.n.*
    $ZIP eof.n
fi
if test -r error.n; then
    rm -f error.n.*
    $ZIP error.n
fi
if test -r eval.n; then
    rm -f eval.n.*
    $ZIP eval.n
fi
if test -r exec.n; then
    rm -f exec.n.*
    $ZIP exec.n
fi
if test -r exit.n; then
    rm -f exit.n.*
    $ZIP exit.n
fi
if test -r expr.n; then
    rm -f expr.n.*
    $ZIP expr.n
fi
if test -r fblocked.n; then
    rm -f fblocked.n.*
    $ZIP fblocked.n
fi
if test -r fconfigure.n; then
    rm -f fconfigure.n.*
    $ZIP fconfigure.n
fi
if test -r fcopy.n; then
    rm -f fcopy.n.*
    $ZIP fcopy.n
fi
if test -r file.n; then
    rm -f file.n.*
    $ZIP file.n
fi
if test -r fileevent.n; then
    rm -f fileevent.n.*
    $ZIP fileevent.n
fi
if test -r filename.n; then
    rm -f filename.n.*
    $ZIP filename.n
fi
if test -r flush.n; then
    rm -f flush.n.*
    $ZIP flush.n
fi
if test -r for.n; then
    rm -f for.n.*
    $ZIP for.n
fi
if test -r foreach.n; then
    rm -f foreach.n.*
    $ZIP foreach.n
fi
if test -r format.n; then
    rm -f format.n.*
    $ZIP format.n
fi
if test -r gets.n; then
    rm -f gets.n.*
    $ZIP gets.n
fi
if test -r glob.n; then
    rm -f glob.n.*
    $ZIP glob.n
fi
if test -r global.n; then
    rm -f global.n.*
    $ZIP global.n
fi
if test -r history.n; then
    rm -f history.n.*
    $ZIP history.n
fi
if test -r http.n; then
    rm -f http.n.*
    $ZIP http.n
fi
if test -r if.n; then
    rm -f if.n.*
    $ZIP if.n
fi
if test -r incr.n; then
    rm -f incr.n.*
    $ZIP incr.n
fi
if test -r info.n; then
    rm -f info.n.*
    $ZIP info.n
fi
if test -r interp.n; then
    rm -f interp.n.*
    $ZIP interp.n
fi
if test -r join.n; then
    rm -f join.n.*
    $ZIP join.n
fi
if test -r lappend.n; then
    rm -f lappend.n.*
    $ZIP lappend.n
fi
if test -r library.n; then
    rm -f library.n.*
    $ZIP library.n
    rm -f auto_execok.n auto_execok.n.* 
    rm -f auto_import.n auto_import.n.* 
    rm -f auto_load.n auto_load.n.* 
    rm -f auto_mkindex.n auto_mkindex.n.* 
    rm -f auto_mkindex_old.n auto_mkindex_old.n.* 
    rm -f auto_qualify.n auto_qualify.n.* 
    rm -f auto_reset.n auto_reset.n.* 
    rm -f tcl_findLibrary.n tcl_findLibrary.n.* 
    rm -f parray.n parray.n.* 
    rm -f tcl_endOfWord.n tcl_endOfWord.n.* 
    rm -f tcl_startOfNextWord.n tcl_startOfNextWord.n.* 
    rm -f tcl_startOfPreviousWord.n tcl_startOfPreviousWord.n.* 
    rm -f tcl_wordBreakAfter.n tcl_wordBreakAfter.n.* 
    rm -f tcl_wordBreakBefore.n tcl_wordBreakBefore.n.* 
    ln $S library.n$Z auto_execok.n$Z 
    ln $S library.n$Z auto_import.n$Z 
    ln $S library.n$Z auto_load.n$Z 
    ln $S library.n$Z auto_mkindex.n$Z 
    ln $S library.n$Z auto_mkindex_old.n$Z 
    ln $S library.n$Z auto_qualify.n$Z 
    ln $S library.n$Z auto_reset.n$Z 
    ln $S library.n$Z tcl_findLibrary.n$Z 
    ln $S library.n$Z parray.n$Z 
    ln $S library.n$Z tcl_endOfWord.n$Z 
    ln $S library.n$Z tcl_startOfNextWord.n$Z 
    ln $S library.n$Z tcl_startOfPreviousWord.n$Z 
    ln $S library.n$Z tcl_wordBreakAfter.n$Z 
    ln $S library.n$Z tcl_wordBreakBefore.n$Z 
fi
if test -r lindex.n; then
    rm -f lindex.n.*
    $ZIP lindex.n
fi
if test -r linsert.n; then
    rm -f linsert.n.*
    $ZIP linsert.n
fi
if test -r list.n; then
    rm -f list.n.*
    $ZIP list.n
fi
if test -r llength.n; then
    rm -f llength.n.*
    $ZIP llength.n
fi
if test -r load.n; then
    rm -f load.n.*
    $ZIP load.n
fi
if test -r lrange.n; then
    rm -f lrange.n.*

    $ZIP lrange.n
fi
if test -r lreplace.n; then
    rm -f lreplace.n.*
    $ZIP lreplace.n
fi
if test -r lsearch.n; then
    rm -f lsearch.n.*
    $ZIP lsearch.n
fi
if test -r lset.n; then
    rm -f lset.n.*
    $ZIP lset.n
fi
if test -r lsort.n; then
    rm -f lsort.n.*
    $ZIP lsort.n
fi
if test -r memory.n; then
    rm -f memory.n.*
    $ZIP memory.n
fi
if test -r msgcat.n; then
    rm -f msgcat.n.*
    $ZIP msgcat.n
fi
if test -r namespace.n; then
    rm -f namespace.n.*
    $ZIP namespace.n
fi
if test -r open.n; then
    rm -f open.n.*
    $ZIP open.n
fi
if test -r package.n; then
    rm -f package.n.*
    $ZIP package.n
fi
if test -r packagens.n; then
    rm -f packagens.n.*
    $ZIP packagens.n
    rm -f pkg::create.n pkg::create.n.* 
    ln $S packagens.n$Z pkg::create.n$Z 
fi
if test -r pid.n; then
    rm -f pid.n.*
    $ZIP pid.n
fi
if test -r pkgMkIndex.n; then
    rm -f pkgMkIndex.n.*
    $ZIP pkgMkIndex.n
    rm -f pkg_mkIndex.n pkg_mkIndex.n.* 
    ln $S pkgMkIndex.n$Z pkg_mkIndex.n$Z 
fi
if test -r proc.n; then
    rm -f proc.n.*
    $ZIP proc.n
fi
if test -r puts.n; then
    rm -f puts.n.*
    $ZIP puts.n
fi
if test -r pwd.n; then
    rm -f pwd.n.*
    $ZIP pwd.n
fi
if test -r re_syntax.n; then
    rm -f re_syntax.n.*
    $ZIP re_syntax.n
fi
if test -r read.n; then
    rm -f read.n.*
    $ZIP read.n
fi
if test -r regexp.n; then
    rm -f regexp.n.*
    $ZIP regexp.n
fi
if test -r registry.n; then
    rm -f registry.n.*
    $ZIP registry.n
fi
if test -r regsub.n; then
    rm -f regsub.n.*
    $ZIP regsub.n
fi
if test -r rename.n; then
    rm -f rename.n.*
    $ZIP rename.n
fi
if test -r resource.n; then
    rm -f resource.n.*
    $ZIP resource.n
fi
if test -r return.n; then
    rm -f return.n.*
    $ZIP return.n
fi
if test -r safe.n; then
    rm -f safe.n.*
    $ZIP safe.n
    rm -f SafeBase.n SafeBase.n.* 
    ln $S safe.n$Z SafeBase.n$Z 
fi
if test -r scan.n; then
    rm -f scan.n.*
    $ZIP scan.n
fi
if test -r seek.n; then
    rm -f seek.n.*
    $ZIP seek.n
fi
if test -r set.n; then
    rm -f set.n.*
    $ZIP set.n
fi
if test -r socket.n; then
    rm -f socket.n.*
    $ZIP socket.n
fi
if test -r source.n; then
    rm -f source.n.*
    $ZIP source.n
fi
if test -r split.n; then
    rm -f split.n.*
    $ZIP split.n
fi
if test -r string.n; then
    rm -f string.n.*
    $ZIP string.n
fi
if test -r subst.n; then
    rm -f subst.n.*
    $ZIP subst.n
fi
if test -r switch.n; then
    rm -f switch.n.*
    $ZIP switch.n
fi
if test -r tclsh.1; then
    rm -f tclsh.1.*
    $ZIP tclsh.1
fi
if test -r tcltest.n; then
    rm -f tcltest.n.*
    $ZIP tcltest.n
fi
if test -r tclvars.n; then
    rm -f tclvars.n.*
    $ZIP tclvars.n
fi
if test -r tell.n; then
    rm -f tell.n.*
    $ZIP tell.n
fi
if test -r time.n; then
    rm -f time.n.*
    $ZIP time.n
fi
if test -r trace.n; then
    rm -f trace.n.*
    $ZIP trace.n
fi
if test -r unknown.n; then
    rm -f unknown.n.*
    $ZIP unknown.n
fi
if test -r unset.n; then
    rm -f unset.n.*
    $ZIP unset.n
fi
if test -r update.n; then
    rm -f update.n.*
    $ZIP update.n
fi
if test -r uplevel.n; then
    rm -f uplevel.n.*
    $ZIP uplevel.n
fi
if test -r upvar.n; then
    rm -f upvar.n.*
    $ZIP upvar.n
fi
if test -r variable.n; then
    rm -f variable.n.*
    $ZIP variable.n
fi
if test -r vwait.n; then
    rm -f vwait.n.*
    $ZIP vwait.n
fi
if test -r while.n; then
    rm -f while.n.*
    $ZIP while.n
fi
exit 0
Changes to unix/mkLinks.tcl.
17
18
19
20
21
22
23
24
















25
26
27
28







29
30
31
32
33
34
35
# Because of the length of command and procedure names, this mechanism
# only works on machines that support file names longer than 14 characters.
# This script checks to see if long file names are supported, and it
# doesn't make any links if they are not.
#
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.

















if test $# != 1; then
    echo "Usage: mkLinks dir"
    exit 1
fi








cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
echo foo > xyzzyTestingaverylongfilename.foo
y=`echo xyzzyTestingav*`
rm xyzzyTe*








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|


>
>
>
>
>
>
>







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
# Because of the length of command and procedure names, this mechanism
# only works on machines that support file names longer than 14 characters.
# This script checks to see if long file names are supported, and it
# doesn't make any links if they are not.
#
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.

ZIP=true
while true; do
    case $1 in
        -s | --symlinks )
            S=-s
            ;;
        -z | --compress )
            ZIP=$2
            shift
            ;;
        *) break
            ;;
    esac
    shift
done

if test $# != 1; then
    echo "Usage: mkLinks <options> dir"
    exit 1
fi

if test "x$ZIP" != "xtrue"; then
    touch TeST
    $ZIP TeST
    Z=`ls TeST* | sed 's/^[^.]*//'`
    rm -f TeST*
fi

cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
echo foo > xyzzyTestingaverylongfilename.foo
y=`echo xyzzyTestingav*`
rm xyzzyTe*
68
69
70
71
72
73
74
75
76
77
78
79
80



81
82
83
84

85
86
87
88
89
90
91
92
93
94
			   set tst $case_insensitive_test 
			   set tstfi $case_insensitive_test_fi 
		    	} else {
			   set tst ""
			   set tstfi ""
		    	}
			lappend namelist $name$ext
			append rmOutput "   $tst rm -f $name$ext$tstfi\n"
			append lnOutput "   $tst ln $tail $name$ext$tstfi\n"
		    }
		}
		if { [llength $namelist] } {
		    puts "if test -r $tail; then"



		    puts -nonewline $rmOutput
		    puts -nonewline $lnOutput
		    puts "fi"
		}

		set state end
	    }
	    end {
		break
	    }
	}
    }
    close $in
}
puts "exit 0"







|
|


<
|
>
>
>


<

>










91
92
93
94
95
96
97
98
99
100
101

102
103
104
105
106
107

108
109
110
111
112
113
114
115
116
117
118
119
			   set tst $case_insensitive_test 
			   set tstfi $case_insensitive_test_fi 
		    	} else {
			   set tst ""
			   set tstfi ""
		    	}
			lappend namelist $name$ext
			append rmOutput "   $tst rm -f $name$ext $name$ext.* $tstfi\n"
			append lnOutput "   $tst ln \$S $tail\$Z $name$ext\$Z $tstfi\n"
		    }
		}

		puts "if test -r $tail; then"
		puts "    rm -f $tail.*"
		puts "    \$ZIP $tail"
		if { [llength $namelist] } {
		    puts -nonewline $rmOutput
		    puts -nonewline $lnOutput

		}
		puts "fi"
		set state end
	    }
	    end {
		break
	    }
	}
    }
    close $in
}
puts "exit 0"
Changes to unix/tcl.m4.
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
			break
		    fi
		done
	    fi

	    # check in a few common install locations
	    if test x"${ac_cv_c_tclconfig}" = x ; then
		for i in `ls -d ${exec_prefix}/lib 2>/dev/null` \
			`ls -d /usr/local/lib 2>/dev/null` \
			`ls -d /usr/contrib/lib 2>/dev/null` \
			`ls -d /usr/lib 2>/dev/null` \
			; do
		    if test -f "$i/tclConfig.sh" ; then
			ac_cv_c_tclconfig=`(cd $i; pwd)`
			break







|







54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
			break
		    fi
		done
	    fi

	    # check in a few common install locations
	    if test x"${ac_cv_c_tclconfig}" = x ; then
		for i in `ls -d ${libdir} 2>/dev/null` \
			`ls -d /usr/local/lib 2>/dev/null` \
			`ls -d /usr/contrib/lib 2>/dev/null` \
			`ls -d /usr/lib 2>/dev/null` \
			; do
		    if test -f "$i/tclConfig.sh" ; then
			ac_cv_c_tclconfig=`(cd $i; pwd)`
			break
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
			ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
			break
		    fi
		done
	    fi
	    # check in a few common install locations
	    if test x"${ac_cv_c_tkconfig}" = x ; then
		for i in `ls -d ${exec_prefix}/lib 2>/dev/null` \
			`ls -d /usr/local/lib 2>/dev/null` \
			`ls -d /usr/contrib/lib 2>/dev/null` \
			`ls -d /usr/lib 2>/dev/null` \
			; do
		    if test -f "$i/tkConfig.sh" ; then
			ac_cv_c_tkconfig=`(cd $i; pwd)`
			break







|







149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
			ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
			break
		    fi
		done
	    fi
	    # check in a few common install locations
	    if test x"${ac_cv_c_tkconfig}" = x ; then
		for i in `ls -d ${libdir} 2>/dev/null` \
			`ls -d /usr/local/lib 2>/dev/null` \
			`ls -d /usr/contrib/lib 2>/dev/null` \
			`ls -d /usr/lib 2>/dev/null` \
			; do
		    if test -f "$i/tkConfig.sh" ; then
			ac_cv_c_tkconfig=`(cd $i; pwd)`
			break
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366


367
368

369
370
371
372
373
374
375
376
377
378
#	Sets the following vars:
#		FRAMEWORK_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_FRAMEWORK, [
    AC_MSG_CHECKING([how to package libraries])
    AC_ARG_ENABLE(framework,
	[  --enable-framework        package shared libraries in frameworks [--enable-framework]],
	[tcl_ok=$enableval], [tcl_ok=no])

    if test "${enable_framework+set}" = set; then
	enableval="$enable_framework"
	tcl_ok=$enableval
    else
	tcl_ok=no
    fi

    if test "$tcl_ok" = "yes" ; then


        if test "${SHARED_BUILD}" = "0" ; then
            AC_MSG_ERROR("Frameworks can only be built if --enable-shared is yes")

        fi
	AC_MSG_RESULT([framework])
	FRAMEWORK_BUILD=1
    else
	AC_MSG_RESULT([standard shared library])
	FRAMEWORK_BUILD=0
    fi
])

#------------------------------------------------------------------------







|










>
>
|
|
>
|
<
<







349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372


373
374
375
376
377
378
379
#	Sets the following vars:
#		FRAMEWORK_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_FRAMEWORK, [
    AC_MSG_CHECKING([how to package libraries])
    AC_ARG_ENABLE(framework,
	[  --enable-framework      package shared libraries in frameworks [--disable-framework]],
	[tcl_ok=$enableval], [tcl_ok=no])

    if test "${enable_framework+set}" = set; then
	enableval="$enable_framework"
	tcl_ok=$enableval
    else
	tcl_ok=no
    fi

    if test "$tcl_ok" = "yes" ; then
	AC_MSG_RESULT([framework])
	FRAMEWORK_BUILD=1
	if test "${SHARED_BUILD}" = "0" ; then
	    AC_MSG_WARN("Frameworks can only be built if --enable-shared is yes")
	    FRAMEWORK_BUILD=0
	fi


    else
	AC_MSG_RESULT([standard shared library])
	FRAMEWORK_BUILD=0
    fi
])

#------------------------------------------------------------------------
496
497
498
499
500
501
502


503
504
505
506
507
508
509
	AC_MSG_RESULT([yes])
    else
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
	DBGX=""
	AC_MSG_RESULT([no])
    fi


])

#------------------------------------------------------------------------
# SC_ENABLE_LANGINFO --
#
#	Allows use of modern nl_langinfo check for better l10n.
#	This is only relevant for Unix.







>
>







497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
	AC_MSG_RESULT([yes])
    else
	CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
	LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
	DBGX=""
	AC_MSG_RESULT([no])
    fi
    AC_SUBST(CFLAGS_DEFAULT)
    AC_SUBST(LDFLAGS_DEFAULT)
])

#------------------------------------------------------------------------
# SC_ENABLE_LANGINFO --
#
#	Allows use of modern nl_langinfo check for better l10n.
#	This is only relevant for Unix.
542
543
544
545
546
547
548










































549
550
551
552
553
554
555
556
557
558
559
560
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
	fi
	if test "$langinfo_ok" = "yes"; then
	    AC_DEFINE(HAVE_LANGINFO)
	fi
    fi
    AC_MSG_RESULT([$langinfo_ok])
])











































#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
#	Try to determine the proper flags to pass to the compiler
#	for building shared libraries and other such nonsense.
#
# Arguments:
#	none
#
# Results:
#
#	Defines the following vars:
#
#       DL_OBJS -       Name of the object file that implements dynamic
#                       loading for Tcl on this system.
#       DL_LIBS -       Library file(s) to include in tclsh and other base
#                       applications in order for the "load" command to work.
#       LDFLAGS -      Flags to pass to the compiler when linking object
#                       files into an executable application binary such
#                       as tclsh.
#       LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
#                       that tell the run-time dynamic linker where to look
#                       for shared libraries such as libtcl.so.  Depends on





#                       the variable LIB_RUNTIME_DIR in the Makefile.
#       MAKE_LIB -      Command to execute to build the Tcl library;
#                       differs depending on whether or not Tcl is being



#                       compiled as a shared library.


#       STLIB_LD -      Base command to use for combining object files
#                       into a static library.
#       SHLIB_CFLAGS -  Flags to pass to cc when compiling the components
#                       of a shared library (may request position-independent
#                       code, among other things).
#       SHLIB_LD -      Base command to use for combining object files
#                       into a shared library.



#       SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
#                       creating shared libraries.  This symbol typically
#                       goes at the end of the "ld" commands that build
#                       shared libraries. The value of the symbol is
#                       "${LIBS}" if all of the dependent libraries should
#                       be specified when creating a shared library.  If
#                       dependent libraries should not be specified (as on
#                       SunOS 4.x, where they cause the link to fail, or in
#                       general if Tcl and Tk aren't themselves shared
#                       libraries), then this symbol has an empty string
#                       as its value.
#       SHLIB_SUFFIX -  Suffix to use for the names of dynamically loadable
#                       extensions.  An empty string means we don't know how
#                       to use shared libraries on this platform.
#       TCL_LIB_FILE -  Name of the file that contains the Tcl library, such
#                       as libtcl7.8.so or libtcl7.8.a.
# TCL_SHLIB_LD_EXTRAS - Additional element which are added to SHLIB_LD_LIBS
#                       for the build of TCL, but not recorded in the
#                       tclConfig.sh, since they are only used for the build
#                       of Tcl. 
#                       Examples: MacOS X records the library version and
#                       compatibility version in the shared library.  But
#                       of course the Tcl version of this is only used for Tcl.
#       TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl"
#                       in the shared library name, using the $VERSION variable
#                       to put the version in the right place.  This is used
#                       by platforms that need non-standard library names.
#                       Examples:  ${VERSION}.so.1.1 on NetBSD, since it needs
#                       to have a version after the .so, and ${VERSION}.a
#                       on AIX, since the Tcl shared library needs to have
#                       a .a extension whereas shared objects for loadable
#                       extensions have a .so extension.  Defaults to
#                       ${VERSION}${SHLIB_SUFFIX}.
#       TCL_NEEDS_EXP_FILE -
#                       1 means that an export file is needed to link to a
#                       shared library.
#       TCL_EXP_FILE -  The name of the installed export / import file which
#                       should be used to link to the Tcl shared library.
#                       Empty if Tcl is unshared.
#       TCL_BUILD_EXP_FILE -
#                       The name of the built export / import file which
#                       should be used to link to the Tcl shared library.
#                       Empty if Tcl is unshared.
#	CFLAGS_DEBUG -
#			Flags used when running the compiler in debug mode
#	CFLAGS_OPTIMIZE -
#			Flags used when running the compiler in optimize mode
#	EXTRA_CFLAGS
#
#	Subst's the following vars:
#		DL_LIBS
#		CFLAGS_DEBUG
#		CFLAGS_OPTIMIZE
#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_CFLAGS, [

    # Step 0.a: Enable 64 bit support?

    AC_MSG_CHECKING([if 64bit support is requested])







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












|











>
>
>
>
>

|
|
>
>
>
|
>
>







>
>
>














<
<







|
|




|



















<
<
<
<







545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655


656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688




689
690
691
692
693
694
695
	fi
	if test "$langinfo_ok" = "yes"; then
	    AC_DEFINE(HAVE_LANGINFO)
	fi
    fi
    AC_MSG_RESULT([$langinfo_ok])
])

#--------------------------------------------------------------------
# SC_CONFIG_MANPAGES
#	
#	Decide whether to use symlinks for linking the manpages and
#	whether to compress the manpages after installation.
#
# Arguments:
#	none
#
# Results:
#
#	Adds the following arguments to configure:
#		--enable-man-symlinks
#		--enable-man-compression=PROG
#
#	Defines the following variable:
#
#	MKLINKS_FLAGS -		The apropriate flags for mkLinks
#				according to the user's selection.
#
#--------------------------------------------------------------------
AC_DEFUN(SC_CONFIG_MANPAGES, [

	AC_MSG_CHECKING([whether to use symlinks for manpages])
	AC_ARG_ENABLE(man-symlinks,
		[  --enable-man-symlinks   use symlinks for the manpages],
		test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --symlinks",
		enableval="no")
	AC_MSG_RESULT([$enableval])

	AC_MSG_CHECKING([compression for manpages])
	AC_ARG_ENABLE(man-compression,
		[  --enable-man-compression=PROG
                          compress the manpages with PROG],
		test "$enableval" = "yes" && echo && AC_MSG_ERROR([missing argument to --enable-man-compression])
		test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --compress $enableval",
		enableval="no")
	AC_MSG_RESULT([$enableval])

	AC_SUBST(MKLINKS_FLAGS)
])

#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
#	Try to determine the proper flags to pass to the compiler
#	for building shared libraries and other such nonsense.
#
# Arguments:
#	none
#
# Results:
#
#	Defines and substitutes the following vars:
#
#       DL_OBJS -       Name of the object file that implements dynamic
#                       loading for Tcl on this system.
#       DL_LIBS -       Library file(s) to include in tclsh and other base
#                       applications in order for the "load" command to work.
#       LDFLAGS -      Flags to pass to the compiler when linking object
#                       files into an executable application binary such
#                       as tclsh.
#       LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
#                       that tell the run-time dynamic linker where to look
#                       for shared libraries such as libtcl.so.  Depends on
#                       the variable LIB_RUNTIME_DIR in the Makefile. Could
#                       be the same as CC_SEARCH_FLAGS if ${CC} is used to link.
#       CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib",
#                       that tell the run-time dynamic linker where to look
#                       for shared libraries such as libtcl.so.  Depends on
#                       the variable LIB_RUNTIME_DIR in the Makefile.
#       MAKE_LIB -      Command to execute to build the a library;
#                       differs when building shared or static.
#       MAKE_STUB_LIB -
#                       Command to execute to build a stub library.
#       INSTALL_LIB -   Command to execute to install a library;
#                       differs when building shared or static.
#       INSTALL_STUB_LIB -
#                       Command to execute to install a stub library.
#       STLIB_LD -      Base command to use for combining object files
#                       into a static library.
#       SHLIB_CFLAGS -  Flags to pass to cc when compiling the components
#                       of a shared library (may request position-independent
#                       code, among other things).
#       SHLIB_LD -      Base command to use for combining object files
#                       into a shared library.
#       SHLIB_LD_FLAGS -Flags to pass when building a shared library. This
#                       differes from the SHLIB_CFLAGS as it is not used
#                       when building object files or executables.
#       SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
#                       creating shared libraries.  This symbol typically
#                       goes at the end of the "ld" commands that build
#                       shared libraries. The value of the symbol is
#                       "${LIBS}" if all of the dependent libraries should
#                       be specified when creating a shared library.  If
#                       dependent libraries should not be specified (as on
#                       SunOS 4.x, where they cause the link to fail, or in
#                       general if Tcl and Tk aren't themselves shared
#                       libraries), then this symbol has an empty string
#                       as its value.
#       SHLIB_SUFFIX -  Suffix to use for the names of dynamically loadable
#                       extensions.  An empty string means we don't know how
#                       to use shared libraries on this platform.


# TCL_SHLIB_LD_EXTRAS - Additional element which are added to SHLIB_LD_LIBS
#                       for the build of TCL, but not recorded in the
#                       tclConfig.sh, since they are only used for the build
#                       of Tcl. 
#                       Examples: MacOS X records the library version and
#                       compatibility version in the shared library.  But
#                       of course the Tcl version of this is only used for Tcl.
#       LIB_SUFFIX -    Specifies everything that comes after the "libfoo"
#                       in a static or shared library name, using the $VERSION variable
#                       to put the version in the right place.  This is used
#                       by platforms that need non-standard library names.
#                       Examples:  ${VERSION}.so.1.1 on NetBSD, since it needs
#                       to have a version after the .so, and ${VERSION}.a
#                       on AIX, since a shared library needs to have
#                       a .a extension whereas shared objects for loadable
#                       extensions have a .so extension.  Defaults to
#                       ${VERSION}${SHLIB_SUFFIX}.
#       TCL_NEEDS_EXP_FILE -
#                       1 means that an export file is needed to link to a
#                       shared library.
#       TCL_EXP_FILE -  The name of the installed export / import file which
#                       should be used to link to the Tcl shared library.
#                       Empty if Tcl is unshared.
#       TCL_BUILD_EXP_FILE -
#                       The name of the built export / import file which
#                       should be used to link to the Tcl shared library.
#                       Empty if Tcl is unshared.
#	CFLAGS_DEBUG -
#			Flags used when running the compiler in debug mode
#	CFLAGS_OPTIMIZE -
#			Flags used when running the compiler in optimize mode
#	EXTRA_CFLAGS
#




#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_CFLAGS, [

    # Step 0.a: Enable 64 bit support?

    AC_MSG_CHECKING([if 64bit support is requested])
739
740
741
742
743
744
745

746
747
748
749
750

751
752
753
754
755
756
757

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # AIX-5 has dl* in libc.so
	    DL_LIBS=""
	    LDFLAGS=""

	    if test "$GCC" = "yes" ; then
		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    else
		LD_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
	    fi


	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		else 
		    do64bit_ok=yes







>

|

|

>







791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # AIX-5 has dl* in libc.so
	    DL_LIBS=""
	    LDFLAGS=""

	    if test "$GCC" = "yes" ; then
	        CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    else
	        CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		else 
		    do64bit_ok=yes
772
773
774
775
776
777
778
779

780
781
782
783
784
785
786
	    SHLIB_CFLAGS=""
	    SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		LIBOBJS="$LIBOBJS tclLoadAix.o"
		DL_LIBS="-lld"







|
>







826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
	    SHLIB_CFLAGS=""
	    SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		LIBOBJS="$LIBOBJS tclLoadAix.o"
		DL_LIBS="-lld"
819
820
821
822
823
824
825

826
827
828
829
830
831
832
833
834
835

836
837
838
839
840
841
842
843
844
845

846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861

862
863
864
865
866
867
868
	    SHLIB_CFLAGS=""
	    SHLIB_LD="shlicc -r"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	BSD/OS-4.*)
	    SHLIB_CFLAGS="-export-dynamic -fPIC"
	    SHLIB_LD="cc -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-export-dynamic"

	    LD_SEARCH_FLAGS=""
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	HP-UX-*.11.*)
	    # Use updated header definitions where possible
	    AC_DEFINE(_XOPEN_SOURCE_EXTENDED)

	    SHLIB_SUFFIX=".sl"
	    AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS='${LIBS}'
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'

	    fi

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		else 







>










>










>















|
>







874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
	    SHLIB_CFLAGS=""
	    SHLIB_LD="shlicc -r"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	BSD/OS-4.*)
	    SHLIB_CFLAGS="-export-dynamic -fPIC"
	    SHLIB_LD="cc -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-export-dynamic"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	HP-UX-*.11.*)
	    # Use updated header definitions where possible
	    AC_DEFINE(_XOPEN_SOURCE_EXTENDED)

	    SHLIB_SUFFIX=".sl"
	    AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS='${LIBS}'
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
	    fi

	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		if test "$GCC" = "yes" ; then
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		else 
878
879
880
881
882
883
884
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
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS=""
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'

	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    EXTRA_CFLAGS=""
	    LDFLAGS=""
	    ;;
	IRIX-6.*|IRIX64-6.5*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    if test "$GCC" = "yes" ; then
		EXTRA_CFLAGS="-mabi=n32"
		LDFLAGS="-mabi=n32"
	    else
		case $system in
		    IRIX-6.3)
			# Use to build 6.2 compatible binaries on 6.3.







|
>










|
>









|
>










|
>







937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS=""
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
		LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    EXTRA_CFLAGS=""
	    LDFLAGS=""
	    ;;
	IRIX-6.*|IRIX64-6.5*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    if test "$GCC" = "yes" ; then
		EXTRA_CFLAGS="-mabi=n32"
		LDFLAGS="-mabi=n32"
	    else
		case $system in
		    IRIX-6.3)
			# Use to build 6.2 compatible binaries on 6.3.
935
936
937
938
939
940
941
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
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'















	    ;;
	Linux*)
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings 
	    # when you inline the string and math operations.  Turn this off to
	    # get rid of the warnings.

	    CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    else
		AC_CHECK_HEADER(dld.h, [
		    SHLIB_LD="ld -shared"
		    DL_OBJS="tclLoadDld.o"
		    DL_LIBS="-ldld"
		    LDFLAGS=""

		    LD_SEARCH_FLAGS=""])
	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi

	    # The combo of gcc + glibc has a bug related







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

















|
>






>







998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'

	    # Check to enable 64-bit flags for compiler/linker

	    if test "$do64bit" = "yes" ; then
	        if test "$GCC" = "yes" ; then
	            AC_MSG_WARN([64bit mode not supported by gcc])
	        else
	            do64bit_ok=yes
	            SHLIB_LD="ld -64 -shared -rdata_shared"
	            EXTRA_CFLAGS="-64"
	            LDFLAGS="-64"
	        fi
	    fi

	    ;;
	Linux*)
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings 
	    # when you inline the string and math operations.  Turn this off to
	    # get rid of the warnings.

	    CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    else
		AC_CHECK_HEADER(dld.h, [
		    SHLIB_LD="ld -shared"
		    DL_OBJS="tclLoadDld.o"
		    DL_LIBS="-ldld"
		    LDFLAGS=""
		    CC_SEARCH_FLAGS=""
		    LD_SEARCH_FLAGS=""])
	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi

	    # The combo of gcc + glibc has a bug related
988
989
990
991
992
993
994

995
996
997
998
999
1000
1001

1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015

1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
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
	    SHLIB_SUFFIX=".so"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS=""
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"

		LD_SEARCH_FLAGS=""
	    else
		AC_CHECK_HEADER(dld.h, [
		    SHLIB_LD="ld -shared"
		    DL_OBJS=""
		    DL_LIBS="-ldld"
		    LDFLAGS=""

		    LD_SEARCH_FLAGS=""])
	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi
	    ;;
	MP-RAS-02*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	MP-RAS-*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-Wl,-Bexport"

	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
	    # Not available on all versions:  check for include file.
	    AC_CHECK_HEADER(dlfcn.h, [
		# NetBSD/SPARC needs -fPIC, -fpic will not do.
		SHLIB_CFLAGS="-fPIC"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		LDFLAGS=""
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

		AC_MSG_CHECKING(for ELF)
		AC_EGREP_CPP(yes, [
#ifdef __ELF__
	yes
#endif
		],
		    AC_MSG_RESULT(yes)
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so',
		    AC_MSG_RESULT(no)
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
		)
	    ], [
		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		LDFLAGS=""
		LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    ])

	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS="-export-dynamic"
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="-pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Rhapsody-*|Darwin-*)
            HACK_PART_1="-DMA"
            HACK_PART_2="C_OSX_TCL"
            EXTRA_CFLAGS="${HACK_PART_1}${HACK_PART_2} -DHAVE_CFBUNDLE"
	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS} "
            TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -framework CoreFoundation"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"
            PLAT_OBJS="tclMacOSXBundle.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    CFLAGS_OPTIMIZE="-Os"
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"


	    LIBS="$LIBS -framework CoreFoundation"
         EXTRA_CFLAGS='-DTCL_DEFAULT_ENCODING=\"utf-8\"'
	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	OS/390-*)
	    CFLAGS_OPTIMIZE=""      # Optimizer is buggy
	    AC_DEFINE(_OE_SOCKETS)  # needed in sys/socket.h
	    ;;      
	OSF1-1.0|OSF1-1.1|OSF1-1.2)
	    # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
	    SHLIB_CFLAGS=""
	    # Hack: make package name same as library name
	    SHLIB_LD='ld -R -export $@:'
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadOSF.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-1.*)
	    # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
	    SHLIB_CFLAGS="-fPIC"
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD="ld -shared"
	    else
	        SHLIB_LD="ld -non_shared"
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-V*)
	    # Digital OSF/1
	    SHLIB_CFLAGS=""
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD='ld -shared -expect_unresolved "*"'
	    else
	        SHLIB_LD='ld -non_shared -expect_unresolved "*"'
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'

	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    # see pthread_intro(3) for pthread support on osf1, k.furukawa
	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"







>







>














>










>













|
>



















|
>

















|
>














<
<
<

|
|



|

|
>



>
>

<









>
















>















>















|
>







1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178



1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194

1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
	    SHLIB_SUFFIX=".so"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS=""
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		CC_SEARCH_FLAGS=""
		LD_SEARCH_FLAGS=""
	    else
		AC_CHECK_HEADER(dld.h, [
		    SHLIB_LD="ld -shared"
		    DL_OBJS=""
		    DL_LIBS="-ldld"
		    LDFLAGS=""
		    CC_SEARCH_FLAGS=""
		    LD_SEARCH_FLAGS=""])
	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi
	    ;;
	MP-RAS-02*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	MP-RAS-*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-Wl,-Bexport"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
	    # Not available on all versions:  check for include file.
	    AC_CHECK_HEADER(dlfcn.h, [
		# NetBSD/SPARC needs -fPIC, -fpic will not do.
		SHLIB_CFLAGS="-fPIC"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		LDFLAGS=""
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
		AC_MSG_CHECKING(for ELF)
		AC_EGREP_CPP(yes, [
#ifdef __ELF__
	yes
#endif
		],
		    AC_MSG_RESULT(yes)
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so',
		    AC_MSG_RESULT(no)
		    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
		)
	    ], [
		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		LDFLAGS=""
		CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    ])

	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS="-export-dynamic"
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="-pthread"
	    	LDFLAGS="$LDFLAGS -pthread"
	    fi
	    case $system in
	    FreeBSD-3.*)
	    	# FreeBSD-3 doesn't handle version numbers with dots.
	    	UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    	SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
	    	TCL_LIB_VERSIONS_OK=nodots
		;;
	    esac
	    ;;
	Rhapsody-*|Darwin-*)



	    SHLIB_CFLAGS="-fno-common"
	    SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
	    TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${LIB_RUNTIME_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".dylib"
	    DL_OBJS="tclLoadDyld.o"
	    PLAT_OBJS="tclMacOSXBundle.o"
	    DL_LIBS=""
	    LDFLAGS="-prebind"
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    CFLAGS_OPTIMIZE="-Os"
	    LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
	    HACK=""
	    EXTRA_CFLAGS="-DMA${HACK}C_OSX_TCL -DHAVE_CFBUNDLE -DTCL_DEFAULT_ENCODING=\\\"utf-8\\\""
	    LIBS="$LIBS -framework CoreFoundation"

	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OS/390-*)
	    CFLAGS_OPTIMIZE=""      # Optimizer is buggy
	    AC_DEFINE(_OE_SOCKETS)  # needed in sys/socket.h
	    ;;      
	OSF1-1.0|OSF1-1.1|OSF1-1.2)
	    # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
	    SHLIB_CFLAGS=""
	    # Hack: make package name same as library name
	    SHLIB_LD='ld -R -export $@:'
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadOSF.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-1.*)
	    # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
	    SHLIB_CFLAGS="-fPIC"
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD="ld -shared"
	    else
	        SHLIB_LD="ld -non_shared"
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-V*)
	    # Digital OSF/1
	    SHLIB_CFLAGS=""
	    if test "$SHARED_BUILD" = "1" ; then
	        SHLIB_LD='ld -shared -expect_unresolved "*"'
	    else
	        SHLIB_LD='ld -non_shared -expect_unresolved "*"'
	    fi
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    # see pthread_intro(3) for pthread support on osf1, k.furukawa
	    if test "${TCL_THREADS}" = "1" ; then
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
		EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
1186
1187
1188
1189
1190
1191
1192

1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
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
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="-melf -Wl,-Bexport"
	    else
	    	SHLIB_CFLAGS="-Kpic -belf"
	    	LDFLAGS="-belf -Wl,-Bexport"
	    fi
	    SHLIB_LD="ld -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	SINIX*5.4*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""

	    LD_SEARCH_FLAGS=""
	    ;;
	SunOS-4*)
	    SHLIB_CFLAGS="-PIC"
	    SHLIB_LD="ld"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'


	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[[0-6]]*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT)
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)

	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"

	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    if test "$GCC" = "yes" ; then

		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'

	    else

		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'

	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT)
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)

	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"
	    LDFLAGS=""
    
	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then







>










|
>

















>










>










|
>



















<










>
|
>

>
|
>











<







1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355

1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383

1384
1385
1386
1387
1388
1389
1390
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # dlopen is in -lc on QNX
	    DL_LIBS=""
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater. However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    if test "$GCC" = "yes" ; then
	    	SHLIB_CFLAGS="-fPIC -melf"
	    	LDFLAGS="-melf -Wl,-Bexport"
	    else
	    	SHLIB_CFLAGS="-Kpic -belf"
	    	LDFLAGS="-belf -Wl,-Bexport"
	    fi
	    SHLIB_LD="ld -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	SINIX*5.4*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	SunOS-4*)
	    SHLIB_CFLAGS="-PIC"
	    SHLIB_LD="ld"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[[0-6]]*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT)
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)

	    SHLIB_CFLAGS="-KPIC"


	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    fi
	    ;;
	SunOS-5*)

	    # Note: If _REENTRANT isn't defined, then Solaris
	    # won't define thread-safe library routines.

	    AC_DEFINE(_REENTRANT)
	    AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)

	    SHLIB_CFLAGS="-KPIC"

	    LDFLAGS=""
    
	    # Check to enable 64-bit flags for compiler/linker
	    if test "$do64bit" = "yes" ; then
		arch=`isainfo`
		if test "$arch" = "sparcv9 sparc" ; then
			if test "$GCC" = "yes" ; then
1311
1312
1313
1314
1315
1316
1317

1318

1319


1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331

1332
1333
1334
1335
1336
1337
1338
	    # 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

		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'

	    else


		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"







>
|
>

>
>











|
>







1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$GCC" = "yes" ; then
		SHLIB_LD="$CC -shared"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    else
		SHLIB_LD="/usr/ccs/bin/ld -G -z text"
		CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    if test "$GCC" != "yes" ; then
		EXTRA_CFLAGS="-DHAVE_TZSET -std1"
	    fi
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
1349
1350
1351
1352
1353
1354
1355

1356
1357
1358
1359
1360
1361
1362
	    LDFLAGS=$hold_ldflags
	    AC_MSG_RESULT($found)
	    if test $found = yes; then
	    LDFLAGS="-Wl,-Bexport"
	    else
	    LDFLAGS=""
	    fi

	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
    AC_MSG_WARN("64bit support being disabled -- don\'t know magic for this platform")
    fi







>







1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
	    LDFLAGS=$hold_ldflags
	    AC_MSG_RESULT($found)
	    if test $found = yes; then
	    LDFLAGS="-Wl,-Bexport"
	    else
	    LDFLAGS=""
	    fi
	    CC_SEARCH_FLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
    AC_MSG_WARN("64bit support being disabled -- don\'t know magic for this platform")
    fi
1453
1454
1455
1456
1457
1458
1459

1460
1461
1462
1463
1464
1465
1466
	echo "on this system."
	SHLIB_CFLAGS=""
	SHLIB_LD=""
	SHLIB_SUFFIX=""
	DL_OBJS="tclLoadNone.o"
	DL_LIBS=""
	LDFLAGS=""

	LD_SEARCH_FLAGS=""
	BUILD_DLTEST=""
    fi

    # If we're running gcc, then change the C flags for compiling shared
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.







>







1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
	echo "on this system."
	SHLIB_CFLAGS=""
	SHLIB_LD=""
	SHLIB_SUFFIX=""
	DL_OBJS="tclLoadNone.o"
	DL_LIBS=""
	LDFLAGS=""
	CC_SEARCH_FLAGS=""
	LD_SEARCH_FLAGS=""
	BUILD_DLTEST=""
    fi

    # If we're running gcc, then change the C flags for compiling shared
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.
1493
1494
1495
1496
1497
1498
1499
1500











































1501




1502
1503
1504





















1505
1506
1507
1508
1509
1510
1511

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi












































    AC_SUBST(DL_LIBS)




    AC_SUBST(CFLAGS_DEBUG)
    AC_SUBST(CFLAGS_OPTIMIZE)
    AC_SUBST(CFLAGS_WARNING)





















])

#--------------------------------------------------------------------
# SC_SERIAL_PORT
#
#	Determine which interface to use to talk to the serial port.
#	Note that #include lines must begin in leftmost column for








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
>
>
>



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi

    AC_REQUIRE([AC_PROG_RANLIB])

    if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
        LIB_SUFFIX=${SHARED_LIB_SUFFIX}
        MAKE_LIB='${SHLIB_LD} -o [$]@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
        INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
    else
        LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}

        if test "$RANLIB" = "" ; then
            MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
        else
            MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@'
            INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))'
        fi

dnl        Not at all clear what this was doing in Tcl's configure.in
dnl        or why it was needed was needed. In any event, this sort of
dnl        things needs to be done in the big loop above.
dnl        REMOVE THIS BLOCK LATER! (mdejong)
dnl        case $system in
dnl            BSD/OS*)
dnl                ;;
dnl            AIX-[[1-4]].*)
dnl                ;;
dnl            *)
dnl                SHLIB_LD_LIBS=""
dnl                ;;
dnl        esac
    fi


    # Stub lib does not depend on shared/static configuration
    if test "$RANLIB" = "" ; then
        MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}'
        INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)'
    else
        MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@'
        INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))'
    fi


    AC_SUBST(DL_LIBS)

    AC_SUBST(DL_OBJS)
    AC_SUBST(PLAT_OBJS)
    AC_SUBST(CFLAGS)
    AC_SUBST(CFLAGS_DEBUG)
    AC_SUBST(CFLAGS_OPTIMIZE)
    AC_SUBST(CFLAGS_WARNING)
    AC_SUBST(EXTRA_CFLAGS)

    AC_SUBST(LDFLAGS)
    AC_SUBST(LDFLAGS_DEBUG)
    AC_SUBST(LDFLAGS_OPTIMIZE)
    AC_SUBST(CC_SEARCH_FLAGS)
    AC_SUBST(LD_SEARCH_FLAGS)

    AC_SUBST(STLIB_LD)
    AC_SUBST(SHLIB_LD)
    AC_SUBST(TCL_SHLIB_LD_EXTRAS)
    AC_SUBST(SHLIB_LD_FLAGS)
    AC_SUBST(SHLIB_LD_LIBS)
    AC_SUBST(SHLIB_CFLAGS)
    AC_SUBST(SHLIB_SUFFIX)

    AC_SUBST(MAKE_LIB)
    AC_SUBST(MAKE_STUB_LIB)
    AC_SUBST(INSTALL_LIB)
    AC_SUBST(INSTALL_STUB_LIB)
    AC_SUBST(RANLIB)
])

#--------------------------------------------------------------------
# SC_SERIAL_PORT
#
#	Determine which interface to use to talk to the serial port.
#	Note that #include lines must begin in leftmost column for
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=none, tcl_cv_api_serial=none)
    fi
    if test $tcl_cv_api_serial = no ; then
	AC_TRY_RUN([
#include <termios.h>
#include <errno.h>

int main() {







|







1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
    fi
    if test $tcl_cv_api_serial = no ; then
	AC_TRY_RUN([
#include <termios.h>
#include <errno.h>

int main() {
1745
1746
1747
1748
1749
1750
1751
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
	    if test ! -r $x_includes/X11/Intrinsic.h; then
		not_really_there="yes"
	    fi
	fi
    fi
    if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then
	AC_MSG_CHECKING(for X11 header files)
	XINCLUDES="# no special path needed"
	AC_TRY_CPP([#include <X11/Intrinsic.h>], , XINCLUDES="nope")
	if test "$XINCLUDES" = nope; then
	    dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include"
	    for i in $dirs ; do
		if test -r $i/X11/Intrinsic.h; then
		    AC_MSG_RESULT($i)
		    XINCLUDES=" -I$i"

		    break
		fi
	    done
	fi
    else
	if test "$x_includes" != ""; then
	    XINCLUDES=-I$x_includes
	else
	    XINCLUDES="# no special path needed"
	fi
    fi
    if test "$XINCLUDES" = nope; then
	AC_MSG_RESULT(couldn't find any!)
	XINCLUDES="# no include files found"
    fi

    if test "$no_x" = yes; then
	AC_MSG_CHECKING(for X11 libraries)
	XLIBSW=nope
	dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib"
	for i in $dirs ; do







|
|
|





>






|
|
<


|

<







1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940

1941
1942
1943
1944

1945
1946
1947
1948
1949
1950
1951
	    if test ! -r $x_includes/X11/Intrinsic.h; then
		not_really_there="yes"
	    fi
	fi
    fi
    if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then
	AC_MSG_CHECKING(for X11 header files)
	found_xincludes="no"
	AC_TRY_CPP([#include <X11/Intrinsic.h>], found_xincludes="yes", found_xincludes="no")
	if test "$found_xincludes" = "no"; then
	    dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include"
	    for i in $dirs ; do
		if test -r $i/X11/Intrinsic.h; then
		    AC_MSG_RESULT($i)
		    XINCLUDES=" -I$i"
		    found_xincludes="yes"
		    break
		fi
	    done
	fi
    else
	if test "$x_includes" != ""; then
	    XINCLUDES="-I$x_includes"
	    found_xincludes="yes"

	fi
    fi
    if test found_xincludes = "no"; then
	AC_MSG_RESULT(couldn't find any!)

    fi

    if test "$no_x" = yes; then
	AC_MSG_CHECKING(for X11 libraries)
	XLIBSW=nope
	dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib"
	for i in $dirs ; do
1963
1964
1965
1966
1967
1968
1969

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
#
#--------------------------------------------------------------------

AC_DEFUN(SC_BUGGY_STRTOD, [
    AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
    if test "$tcl_strtod" = 1; then
	AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs])

	AC_TRY_RUN([
	    extern double strtod();
	    int main()
	    {
		char *string = "NaN", *spaceString = " ";
		char *term;
		double value;
		value = strtod(string, &term);
		if ((term != string) && (term[-1] == 0)) {
		    exit(1);
		}




		value = strtod(spaceString, &term);
		if (term == (spaceString+1)) {
		    exit(1);
		}
		exit(0);
	    }], tcl_ok=1, tcl_ok=0, tcl_ok=0)
	if test "$tcl_ok" = 1; then
	    AC_MSG_RESULT(ok)
	else
	    AC_MSG_RESULT(buggy)
	    LIBOBJS="$LIBOBJS fixstrtod.o"
	    AC_DEFINE(strtod, fixstrtod)
	fi
    fi







>
|
|
|
<
|
|
|
|
|
|
|
>
>
>
>
|
|
|
|
|
|
|







2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144

2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
#
#--------------------------------------------------------------------

AC_DEFUN(SC_BUGGY_STRTOD, [
    AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
    if test "$tcl_strtod" = 1; then
	AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs])
	AC_CACHE_VAL(tcl_cv_strtod_buggy,[
	    AC_TRY_RUN([
		extern double strtod();
		int main() {

		    char *infString="Inf", *nanString="NaN", *spaceString=" ";
		    char *term;
		    double value;
		    value = strtod(infString, &term);
		    if ((term != infString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(nanString, &term);
		    if ((term != nanString) && (term[-1] == 0)) {
			exit(1);
		    }
		    value = strtod(spaceString, &term);
		    if (term == (spaceString+1)) {
			exit(1);
		    }
		    exit(0);
		}], tcl_cv_strtod_buggy=1, tcl_cv_strtod_buggy=0, tcl_cv_strtod_buggy=0)])
	if test "$tcl_cv_strtod_buggy" = 1; then
	    AC_MSG_RESULT(ok)
	else
	    AC_MSG_RESULT(buggy)
	    LIBOBJS="$LIBOBJS fixstrtod.o"
	    AC_DEFINE(strtod, fixstrtod)
	fi
    fi
Changes to unix/tcl.spec.
1
2
3
4
5
6
7
8
9
10
11
# $Id: tcl.spec,v 1.8.8.1 2002/06/10 05:33:18 wolfsuit Exp $
# This file is the basis for a binary Tcl RPM for Linux.

%define version 8.4a5
%define directory /usr/local

Summary: Tcl scripting language development environment
Name: tcl
Version: %{version}
Release: 1
Copyright: BSD
|


|







1
2
3
4
5
6
7
8
9
10
11
# $Id: tcl.spec,v 1.8.8.2 2002/08/20 20:25:30 das Exp $
# This file is the basis for a binary Tcl RPM for Linux.

%define version 8.4b3
%define directory /usr/local

Summary: Tcl scripting language development environment
Name: tcl
Version: %{version}
Release: 1
Copyright: BSD
Changes to unix/tclConfig.sh.in.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# tclConfig.sh --
# 
# This shell script (for sh) is generated automatically by Tcl's
# configure script.  It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Tcl extensions so that they don't have to figure this all
# out for themselves.
#
# The information in this file is specific to a single platform.
#
# RCS: @(#) $Id: tclConfig.sh.in,v 1.15.12.1 2002/02/05 02:22:05 wolfsuit 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@'












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# tclConfig.sh --
# 
# This shell script (for sh) is generated automatically by Tcl's
# configure script.  It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Tcl extensions so that they don't have to figure this all
# out for themselves.
#
# The information in this file is specific to a single platform.
#
# RCS: @(#) $Id: tclConfig.sh.in,v 1.15.12.2 2002/08/20 20:25:30 das Exp $

# Tcl's version number.
TCL_VERSION='@TCL_VERSION@'
TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@'
TCL_MINOR_VERSION='@TCL_MINOR_VERSION@'
TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@'

92
93
94
95
96
97
98

99
100
101
102
103
104
105
106
# an executable tclsh or tcltest binary.
TCL_LD_FLAGS='@LDFLAGS@'

# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the
# run-time dynamic linker where to look for shared libraries such as
# libtcl.so.  Used when linking applications.  Only works if there
# is a variable "LIB_RUNTIME_DIR" defined in the Makefile.

TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@'

# Additional object files linked with Tcl to provide compatibility
# with standard facilities from ANSI C or POSIX.
TCL_COMPAT_OBJS='@LIBOBJS@'

# Name of the ranlib program to use.
TCL_RANLIB='@RANLIB@'







>
|







92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
# an executable tclsh or tcltest binary.
TCL_LD_FLAGS='@LDFLAGS@'

# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the
# run-time dynamic linker where to look for shared libraries such as
# libtcl.so.  Used when linking applications.  Only works if there
# is a variable "LIB_RUNTIME_DIR" defined in the Makefile.
TCL_CC_SEARCH_FLAGS='@CC_SEARCH_FLAGS@'
TCL_LD_SEARCH_FLAGS='@LD_SEARCH_FLAGS@'

# Additional object files linked with Tcl to provide compatibility
# with standard facilities from ANSI C or POSIX.
TCL_COMPAT_OBJS='@LIBOBJS@'

# Name of the ranlib program to use.
TCL_RANLIB='@RANLIB@'
Changes to unix/tclLoadAout.c.
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This work was supported in part by the ARPA Manufacturing Automation
 * and Design Engineering (MADE) Initiative through ARPA contract
 * F33615-94-C-4400.
 *
 * RCS: @(#) $Id: tclLoadAout.c,v 1.7.2.2 2002/06/10 05:33:18 wolfsuit Exp $
 */

#include "tclInt.h"
#include <fcntl.h>
#ifdef HAVE_EXEC_AOUT_H
#   include <sys/exec_aout.h>
#endif







|







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * This work was supported in part by the ARPA Manufacturing Automation
 * and Design Engineering (MADE) Initiative through ARPA contract
 * F33615-94-C-4400.
 *
 * RCS: @(#) $Id: tclLoadAout.c,v 1.7.2.3 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include <fcntl.h>
#ifdef HAVE_EXEC_AOUT_H
#   include <sys/exec_aout.h>
#endif
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName,
				      Tcl_DString * buf));
static void UnlinkSymbolTable _ANSI_ARGS_((void));

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.  *proc1Ptr and *proc2Ptr
 *	are filled in with the addresses of the symbols given by
 *	*sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *
 * Bugs:
 *	This function does not attempt to handle the case where the







|


<
|



|
<
<







98
99
100
101
102
103
104
105
106
107

108
109
110
111
112


113
114
115
116
117
118
119
static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName,
				      Tcl_DString * buf));
static void UnlinkSymbolTable _ANSI_ARGS_((void));

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result. 


 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *
 * Bugs:
 *	This function does not attempt to handle the case where the
137
138
139
140
141
142
143
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
 *	fail with an `inconsistent memory allocation' error.
 *	It perhaps ought to retry the link, but the failure has
 *	not been observed in two years of daily use of this function.
 *----------------------------------------------------------------------
 */

int
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. */
{
  char * inputSymbolTable;	/* Name of the file containing the 
				 * symbol table from the last link. */
  Tcl_DString linkCommandBuf;	/* Command to do the run-time relocation
				 * of the module.*/
  char * linkCommand;
  char relocatedFileName [L_tmpnam];
				/* Name of the file holding the relocated */
				/* text of the module */
  int relocatedFd;		/* File descriptor of the file holding
				 * relocated text */
  struct exec relocatedHead;	/* Header of the relocated text */
  unsigned long relocatedSize;	/* Size of the relocated text */
  char * startAddress;		/* Starting address of the module */
  DictFn dictionary;		/* Dictionary function in the load module */
  int status;			/* Status return from Tcl_ calls */
  char * p;

  *clientDataPtr = NULL;
  
  /* Find the file that contains the symbols for the run-time link. */

  if (SymbolTableFile != NULL) {
    inputSymbolTable = SymbolTableFile;
  } else if (tclExecutableName == NULL) {
    Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
    return TCL_ERROR;







<
|



<
<
<
<
<
|




















<



<
<







134
135
136
137
138
139
140

141
142
143
144





145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165

166
167
168


169
170
171
172
173
174
175
 *	fail with an `inconsistent memory allocation' error.
 *	It perhaps ought to retry the link, but the failure has
 *	not been observed in two years of daily use of this function.
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
  char * inputSymbolTable;	/* Name of the file containing the 
				 * symbol table from the last link. */
  Tcl_DString linkCommandBuf;	/* Command to do the run-time relocation
				 * of the module.*/
  char * linkCommand;
  char relocatedFileName [L_tmpnam];
				/* Name of the file holding the relocated */
				/* text of the module */
  int relocatedFd;		/* File descriptor of the file holding
				 * relocated text */
  struct exec relocatedHead;	/* Header of the relocated text */
  unsigned long relocatedSize;	/* Size of the relocated text */
  char * startAddress;		/* Starting address of the module */

  int status;			/* Status return from Tcl_ calls */
  char * p;



  /* Find the file that contains the symbols for the run-time link. */

  if (SymbolTableFile != NULL) {
    inputSymbolTable = SymbolTableFile;
  } else if (tclExecutableName == NULL) {
    Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
    return TCL_ERROR;
313
314
315
316
317
318
319



320


321



















322
323
324
325
326
327
328
329
330
331
332
333
334
    UnlinkSymbolTable ();
  } else {
    atexit (UnlinkSymbolTable);
  }
  SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
  strcpy (SymbolTableFile, relocatedFileName);
  



  /* Look up the entry points in the load module's dictionary. */






















  dictionary = (DictFn) startAddress;
  *proc1Ptr = dictionary (sym1);
  *proc2Ptr = dictionary (sym2);

  return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * FindLibraries --
 *
 *	Find the libraries needed to link a load module at run time.







>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
<
|
<
|







301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335

336

337
338
339
340
341
342
343
344
    UnlinkSymbolTable ();
  } else {
    atexit (UnlinkSymbolTable);
  }
  SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
  strcpy (SymbolTableFile, relocatedFileName);
  
  *loadHandle = startAddress;
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    /* Look up the entry point in the load module's dictionary. */
    DictFn dictionary = (DictFn) loadHandle;
    return (Tcl_PackageInitProc*) dictionary(sym1);

}



/*
 *------------------------------------------------------------------------
 *
 * FindLibraries --
 *
 *	Find the libraries needed to link a load module at run time.
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------







|
|
|







457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------
Changes to unix/tclLoadDl.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclLoadDl.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the "dlopen" and "dlsym" library procedures for
 *	dynamic loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDl.c,v 1.7.2.1 2002/02/05 02:22:05 wolfsuit Exp $
 */

#include "tclInt.h"
#ifdef NO_DLFCN_H
#   include "../compat/dlfcn.h"
#else
#   include <dlfcn.h>












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclLoadDl.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the "dlopen" and "dlsym" library procedures for
 *	dynamic loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDl.c,v 1.7.2.2 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#ifdef NO_DLFCN_H
#   include "../compat/dlfcn.h"
#else
#   include <dlfcn.h>
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
#ifndef RTLD_GLOBAL
#   define RTLD_GLOBAL 0
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.  *proc1Ptr and *proc2Ptr
 *	are filled in with the addresses of the symbols given by
 *	*sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *---------------------------------------------------------------------------
 */

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. */
    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. */
{
    VOID *handle;
    Tcl_DString newName, ds;
    CONST char *native;

    native = Tcl_FSGetNativePath(pathPtr);
    handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);	/* INTL: Native. */
    
    *clientDataPtr = (ClientData) handle;
    
    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", dlerror(), (char *) NULL);
	return TCL_ERROR;
    }

    *unloadProcPtr = &TclpUnloadFile;


    


























    /* 
     * 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, sym1, -1, &ds);
    *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
	    native);	
    if (*proc1Ptr == NULL) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	native = Tcl_DStringAppend(&newName, native, -1);
	*proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
		native);
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);

    native = Tcl_UtfToExternalDString(NULL, sym2, -1, &ds);
    *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
	    native);
    if (*proc2Ptr == NULL) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	native = Tcl_DStringAppend(&newName, native, -1);
	*proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
		native);
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);
    
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *







|


<
|



|
<
<








<
|


|
<
<
<
<
<
|








<





<
<








>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|
|

|



|





<
<
<
<
<
<
<
<
<
<
<
<
<
|







34
35
36
37
38
39
40
41
42
43

44
45
46
47
48


49
50
51
52
53
54
55
56

57
58
59
60





61
62
63
64
65
66
67
68
69

70
71
72
73
74


75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130













131
132
133
134
135
136
137
138
#ifndef RTLD_GLOBAL
#   define RTLD_GLOBAL 0
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result. 


 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *---------------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    VOID *handle;

    CONST char *native;

    native = Tcl_FSGetNativePath(pathPtr);
    handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);	/* INTL: Native. */
    


    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", dlerror(), (char *) NULL);
	return TCL_ERROR;
    }

    *unloadProcPtr = &TclpUnloadFile;
    *loadHandle = (Tcl_LoadHandle)handle;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    CONST char *native;
    Tcl_DString newName, ds;
    VOID *handle = (VOID*)loadHandle;
    Tcl_PackageInitProc *proc;
    /* 
     * Some platforms still add an underscore to the beginning of symbol
     * names.  If we can't find a name without an underscore, try again
     * with the underscore.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    proc = (Tcl_PackageInitProc *) dlsym(handle,	/* INTL: Native. */
	    native);	
    if (proc == NULL) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	native = Tcl_DStringAppend(&newName, native, -1);
	proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
		native);
	Tcl_DStringFree(&newName);
    }
    Tcl_DStringFree(&ds);














    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
    VOID *handle;

    handle = (VOID *) clientData;
    dlclose(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --







|
|
|





|







146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    VOID *handle;

    handle = (VOID *) loadHandle;
    dlclose(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
Changes to unix/tclLoadDld.c.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
 *	makes more sense to use "dl_open" etc.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDld.c,v 1.6.2.1 2002/02/05 02:22:05 wolfsuit 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

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.  *proc1Ptr and *proc2Ptr
 *	are filled in with the addresses of the symbols given by
 *	*sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

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. */
    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. */
{
    static int firstTime = 1;
    int returnCode;
    char *fileName = Tcl_GetString(pathPtr);
    
    /*
     *  The dld package needs to know the pathname to the tcl binary.
     *  If that's not know, 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);







|

















|


<
|



|
<
<








<
|


|
<
<
<
<
<
|













|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

36
37
38
39
40


41
42
43
44
45
46
47
48

49
50
51
52





53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
 *	makes more sense to use "dl_open" etc.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDld.c,v 1.6.2.2 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include "dld.h"

/*
 * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined
 * and this argument to dlopen must always be 1.
 */

#ifndef RTLD_NOW
#   define RTLD_NOW 1
#endif

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.


 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    static int firstTime = 1;
    int returnCode;
    char *fileName = Tcl_GetString(pathPtr);
    
    /*
     *  The dld package needs to know the pathname to the tcl binary.
     *  If that's not known, return an error.
     */

    if (firstTime) {
	if (tclExecutableName == NULL) {
	    Tcl_SetResult(interp,
		    "don't know name of application binary file, so can't initialize dynamic loader",
		    TCL_STATIC);
95
96
97
98
99
100
101
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

    if ((returnCode = dld_link(Tcl_GetString(pathPtr))) != 0) {
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", dld_strerror(returnCode), (char *) NULL);
	return TCL_ERROR;
    }
    *proc1Ptr = (Tcl_PackageInitProc *) dld_get_func(sym1);
    *proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2);
    *clientDataPtr = strcpy(
	    (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

























/*
 *----------------------------------------------------------------------
 *
 * 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(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
    char *fileName;

    handle = (char *) clientData;
    dld_unlink_by_file(handle, 0);
    ckfree(handle);
}

/*
 *----------------------------------------------------------------------
 *







<
<
|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




















|
|
|





|







86
87
88
89
90
91
92


93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157

    if ((returnCode = dld_link(Tcl_GetString(pathPtr))) != 0) {
	Tcl_AppendResult(interp, "couldn't load file \"", 
			 Tcl_GetString(pathPtr),
			 "\": ", dld_strerror(returnCode), (char *) NULL);
	return TCL_ERROR;
    }


    *loadHandle = strcpy(
	    (char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return (Tcl_PackageInitProc *) dld_get_func(symbol);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    char *fileName;

    handle = (char *) loadHandle;
    dld_unlink_by_file(handle, 0);
    ckfree(handle);
}

/*
 *----------------------------------------------------------------------
 *
Changes to unix/tclLoadDyld.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20










21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
/* 
 * tclLoadDyld.c --
 *
 *     This procedure provides a version of the TclLoadFile that
 *     works with Apple's dyld dynamic loading.  This file
 *     provided by Wilfredo Sanchez (wsanchez@apple.com).
 *     This works on Mac OS X.
 *
 * Copyright (c) 1995 Apple Computer, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDyld.c,v 1.5.2.3 2002/02/25 15:22:30 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <mach-o/dyld.h>











/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *     Dynamically loads a binary code file into memory and returns
 *     the addresses of two procedures within that file, if they
 *     are defined.
 *
 * Results:
 *     A standard Tcl completion code.  If an error occurs, an error
 *     message is left in the interpreter's result.  *proc1Ptr and *proc2Ptr
 *     are filled in with the addresses of the symbols given by
 *     *sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *     New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

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. */
    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. */
{
    NSSymbol symbol;
    const struct mach_header *dyld_lib;
    Tcl_DString newName, ds;
    char *native;

    native = Tcl_FSGetNativePath(pathPtr);
    dyld_lib = NSAddImage(native, 
        NSADDIMAGE_OPTION_WITH_SEARCHING | 
        NSADDIMAGE_OPTION_RETURN_ON_ERROR);
    
    if (!dyld_lib) {
        NSLinkEditErrors editError;
        char *name, *msg;
        NSLinkEditError(&editError, &errno, &name, &msg);
        Tcl_AppendResult(interp, msg, (char *) NULL);
        return TCL_ERROR;
    }





    *unloadProcPtr = &TclpUnloadFile;





























    /* 
     * dyld adds an underscore to the beginning of symbol names.
     */

    native = Tcl_UtfToExternalDString(NULL, sym1, -1, &ds);
    Tcl_DStringInit(&newName);
    Tcl_DStringAppend(&newName, "_", 1);
    native = Tcl_DStringAppend(&newName, native, -1);
    symbol = NSLookupSymbolInImage(dyld_lib, native, 
        NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | 
        NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
    if(symbol) {

        *proc1Ptr = NSAddressOfSymbol(symbol);


        *clientDataPtr = NSModuleForSymbol(symbol);
    } else {
        *proc1Ptr=NULL;
        *clientDataPtr=NULL;
    }

    Tcl_DStringFree(&newName);
    Tcl_DStringFree(&ds);

    native = Tcl_UtfToExternalDString(NULL, sym2, -1, &ds);
    Tcl_DStringInit(&newName);
    Tcl_DStringAppend(&newName, "_", 1);
    native = Tcl_DStringAppend(&newName, native, -1);
    symbol = NSLookupSymbolInImage(dyld_lib, native, 
        NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | 
        NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
    if(symbol) {
        *proc2Ptr = NSAddressOfSymbol(symbol);
    } else {
        *proc2Ptr=NULL;
    }
    Tcl_DStringFree(&newName);
    Tcl_DStringFree(&ds);

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *













|






>
>
>
>
>
>
>
>
>
>



|

|
|
<



|
<
<








<
|


|
<
<
<
<
<
|







|

<
|













|
>
>
>
>

>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|



|
|
|
|
>
|
>
>
|
<
<
<
<
>
|
<
|
<
<
<
<
<
<
<
<
<
<
<



|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41


42
43
44
45
46
47
48
49

50
51
52
53





54
55
56
57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129




130
131

132











133
134
135
136
137
138
139
140
141
142
143
144
/* 
 * tclLoadDyld.c --
 *
 *     This procedure provides a version of the TclLoadFile that
 *     works with Apple's dyld dynamic loading.  This file
 *     provided by Wilfredo Sanchez (wsanchez@apple.com).
 *     This works on Mac OS X.
 *
 * Copyright (c) 1995 Apple Computer, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadDyld.c,v 1.5.2.4 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <mach-o/dyld.h>

typedef struct Tcl_DyldModuleHandle {
    struct Tcl_DyldModuleHandle *nextModuleHandle;
    NSModule module;
} Tcl_DyldModuleHandle;

typedef struct Tcl_DyldLoadHandle {
    const struct mach_header *dyld_lib;
    Tcl_DyldModuleHandle *firstModuleHandle;
} Tcl_DyldLoadHandle;

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	a handle to the new code.

 *
 * Results:
 *     A standard Tcl completion code.  If an error occurs, an error
 *     message is left in the interpreter's result. 


 *
 * Side effects:
 *     New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle;
    const struct mach_header *dyld_lib;

    CONST char *native;

    native = Tcl_FSGetNativePath(pathPtr);
    dyld_lib = NSAddImage(native, 
        NSADDIMAGE_OPTION_WITH_SEARCHING | 
        NSADDIMAGE_OPTION_RETURN_ON_ERROR);
    
    if (!dyld_lib) {
        NSLinkEditErrors editError;
        char *name, *msg;
        NSLinkEditError(&editError, &errno, &name, &msg);
        Tcl_AppendResult(interp, msg, (char *) NULL);
        return TCL_ERROR;
    }
    dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle));
    if (!dyldLoadHandle) return TCL_ERROR;
    dyldLoadHandle->dyld_lib = dyld_lib;
    dyldLoadHandle->firstModuleHandle = NULL;
    *loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    NSSymbol nsSymbol;
    CONST char *native;
    Tcl_DString newName, ds;
    Tcl_PackageInitProc* proc = NULL;
    Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
    /* 
     * dyld adds an underscore to the beginning of symbol names.
     */

    native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
    Tcl_DStringInit(&newName);
    Tcl_DStringAppend(&newName, "_", 1);
    native = Tcl_DStringAppend(&newName, native, -1);
    nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyld_lib, native, 
	NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW | 
	NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
    if(nsSymbol) {
	Tcl_DyldModuleHandle *dyldModuleHandle;
	proc = NSAddressOfSymbol(nsSymbol);
	dyldModuleHandle = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
	if (dyldModuleHandle) {
	    dyldModuleHandle->module = NSModuleForSymbol(nsSymbol);




	    dyldModuleHandle->nextModuleHandle = dyldLoadHandle->firstModuleHandle;
	    dyldLoadHandle->firstModuleHandle = dyldModuleHandle;

	}











    }
    Tcl_DStringFree(&newName);
    Tcl_DStringFree(&ds);
    
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
133
134
135
136
137
138
139
140
141
142
143
144
145



146







147
148
149
150
151
152
153
 *     Code dissapears from memory.
 *     Note that this is a no-op on older (OpenStep) versions of dyld.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{



    NSUnLinkModule(clientData, FALSE);







}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *







|
|
|



>
>
>
|
>
>
>
>
>
>
>







153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
 *     Code dissapears from memory.
 *     Note that this is a no-op on older (OpenStep) versions of dyld.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
    Tcl_DyldModuleHandle *dyldModuleHandle = dyldLoadHandle->firstModuleHandle;
    void *ptr;

    while (dyldModuleHandle) {
	NSUnLinkModule(dyldModuleHandle->module, NSUNLINKMODULE_OPTION_NONE);
	ptr = dyldModuleHandle;
	dyldModuleHandle = dyldModuleHandle->nextModuleHandle;
	ckfree(ptr);
    }
    ckfree(dyldLoadHandle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
 *
Changes to unix/tclLoadNext.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
/* 
 * tclLoadNext.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with NeXTs rld_* dynamic loading.  This file provided
 *	by Pedja Bogdanovich.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadNext.c,v 1.6.2.1 2002/02/05 02:22:05 wolfsuit Exp $
 */

#include "tclInt.h"
#include <mach-o/rld.h>
#include <streams/streams.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.  *proc1Ptr and *proc2Ptr
 *	are filled in with the addresses of the symbols given by
 *	*sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

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. */
    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. */
{












|









|


<
|



|
<
<








<
|


|
<
<
<
<
<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30


31
32
33
34
35
36
37
38

39
40
41
42





43
44
45
46
47
48
49
50
/* 
 * tclLoadNext.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with NeXTs rld_* dynamic loading.  This file provided
 *	by Pedja Bogdanovich.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadNext.c,v 1.6.2.2 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include <mach-o/rld.h>
#include <streams/streams.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.


 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
68
69
70
71
72
73
74
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
    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);

  *proc1Ptr=NULL;
  if(sym1) {
    char sym[strlen(sym1)+2];
    sym[0]='_'; sym[1]=0; strcat(sym,sym1);
    rld_lookup(NULL,sym,(unsigned long *)proc1Ptr);
  }






















  *proc2Ptr=NULL;
  if(sym2) {
    char sym[strlen(sym2)+2];
    sym[0]='_'; sym[1]=0; strcat(sym,sym2);
    rld_lookup(NULL,sym,(unsigned long *)proc2Ptr);
  }
  *clientDataPtr = NULL;
  *unloadProcPtr = &TclpUnloadFile;
  
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------







|
|
|
|
<
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
<
<
<
|





















|
|
|







59
60
61
62
63
64
65
66
67
68
69

70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98



99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
    NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
    Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL);
    NXCloseMemory(errorStream,NX_FREEBUFFER);
    return TCL_ERROR;
  }
  NXCloseMemory(errorStream,NX_FREEBUFFER);

  *loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */
  *unloadProcPtr = &TclpUnloadFile;
  
  return TCL_OK;

}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_PackageInitProc *proc=NULL;
    if(symbol) {
	char sym[strlen(symbol)+2];
	sym[0]='_'; sym[1]=0; strcat(sym,symbol);
	rld_lookup(NULL,sym,(unsigned long *)&proc);
    }



    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------
Changes to unix/tclLoadOSF.c.
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
 *	John Robert LoVerso <loverso@freebsd.osf.org>
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadOSF.c,v 1.6.2.1 2002/02/05 02:22:05 wolfsuit Exp $
 */

#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.  *proc1Ptr and *proc2Ptr
 *	are filled in with the addresses of the symbols given by
 *	*sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

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. */
    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. */
{







|









|


<
|



|
<
<








<
|


|
<
<
<
<
<
|







27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

47
48
49
50
51


52
53
54
55
56
57
58
59

60
61
62
63





64
65
66
67
68
69
70
71
 *	John Robert LoVerso <loverso@freebsd.osf.org>
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadOSF.c,v 1.6.2.2 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.


 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
95
96
97
98
99
100
101
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
     * 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++;

    *proc1Ptr = ldr_lookup_package(pkg, sym1);
    *proc2Ptr = ldr_lookup_package(pkg, sym2);
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

























/*
 *----------------------------------------------------------------------
 *
 * 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(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------







|
|
|

>
|
<



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




















|
|
|







86
87
88
89
90
91
92
93
94
95
96
97
98

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
     * My convention is to use a [OSF loader] package name the same as shlib,
     * since the idiots never implemented ldr_lookup() and it is otherwise
     * impossible to get a package name given a module.
     *
     * I build loadable modules with a makefile rule like 
     *		ld ... -export $@: -o $@ $(OBJS)
     */
    if ((pkg = strrchr(fileName, '/')) == NULL) {
        pkg = fileName;
    } else {
	pkg++;
    }
    *loadHandle = pkg;

    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    return ldr_lookup_package((char *)loadHandle, symbol);
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
 *	Unloads a dynamically loaded binary code file from memory.
 *	Code pointers in the formerly loaded file are no longer valid
 *	after calling this function.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Does nothing.  Can anything be done?
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
}

/*
 *----------------------------------------------------------------------
Changes to unix/tclLoadShl.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
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
/* 
 * tclLoadShl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works
 *	with the "shl_load" and "shl_findsym" library procedures for
 *	dynamic loading (e.g. for HP machines).
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadShl.c,v 1.8.2.1 2002/02/05 02:22:05 wolfsuit Exp $
 */

#include <dl.h>

/*
 * On some HP machines, dl.h defines EXTERN; remove that definition.
 */

#ifdef EXTERN
#   undef EXTERN
#endif

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.  *proc1Ptr and *proc2Ptr
 *	are filled in with the addresses of the symbols given by
 *	*sym1 and *sym2, or NULL if those symbols can't be found.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

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. */
    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. */
{
    shl_t handle;
    Tcl_DString newName;
    char *fileName = Tcl_GetString(pathPtr);
    
    /*
     * The flags below used to be BIND_IMMEDIATE; they were changed at
     * the suggestion of Wolfgang Kechel (wolfgang@prs.de): "This
     * enables verbosity for missing symbols when loading a shared lib
     * and allows to load libtk8.0.sl into tclsh8.0 without problems.
     * In general, this delays resolving symbols until they are actually
     * needed.  Shared libs do no longer need all libraries linked in
     * when they are build."
     */

    handle = shl_load(fileName,
		      BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH,
		      0L);
    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName,
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }




    *clientDataPtr = (ClientData) handle;
























    /*
     * 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, sym1, (short) TYPE_PROCEDURE, (void *) proc1Ptr)
	    != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, sym1, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) proc1Ptr) != 0) {
	    *proc1Ptr = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    if (shl_findsym(&handle, sym2, (short) TYPE_PROCEDURE, (void *) proc2Ptr)
	    != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, sym2, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) proc2Ptr) != 0) {
	    *proc2Ptr = NULL;
	}
	Tcl_DStringFree(&newName);
    }
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *












|

















|


<
|



|
<
<








<
|


|
<
<
<
<
<
|








<




















>
>
>
>
|
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






<
<
<
<
<
<
|
<
<
<
<
<



|

|
|



<
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

34
35
36
37
38


39
40
41
42
43
44
45
46

47
48
49
50





51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114






115





116
117
118
119
120
121
122
123
124
125

126
127
128
129
130
131
132
133
/* 
 * tclLoadShl.c --
 *
 *	This procedure provides a version of the TclLoadFile that works
 *	with the "shl_load" and "shl_findsym" library procedures for
 *	dynamic loading (e.g. for HP machines).
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclLoadShl.c,v 1.8.2.2 2002/08/20 20:25:30 das Exp $
 */

#include <dl.h>

/*
 * On some HP machines, dl.h defines EXTERN; remove that definition.
 */

#ifdef EXTERN
#   undef EXTERN
#endif

#include "tclInt.h"

/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.


 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    shl_t handle;

    char *fileName = Tcl_GetString(pathPtr);
    
    /*
     * The flags below used to be BIND_IMMEDIATE; they were changed at
     * the suggestion of Wolfgang Kechel (wolfgang@prs.de): "This
     * enables verbosity for missing symbols when loading a shared lib
     * and allows to load libtk8.0.sl into tclsh8.0 without problems.
     * In general, this delays resolving symbols until they are actually
     * needed.  Shared libs do no longer need all libraries linked in
     * when they are build."
     */

    handle = shl_load(fileName,
		      BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH,
		      0L);
    if (handle == NULL) {
	Tcl_AppendResult(interp, "couldn't load file \"", fileName,
		"\": ", Tcl_PosixError(interp), (char *) NULL);
	return TCL_ERROR;
    }
    *loadHandle = (Tcl_LoadHandle) handle;
    *unloadProcPtr = &TclpUnloadFile;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_DString newName;
    Tcl_PackageInitProc *proc=NULL;
    shl_t handle = (shl_t)loadHandle;
    /*
     * Some versions of the HP system software still use "_" at the
     * beginning of exported symbols while others don't;  try both
     * forms of each name.
     */







    if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, (void *) &proc)





	    != 0) {
	Tcl_DStringInit(&newName);
	Tcl_DStringAppend(&newName, "_", 1);
	Tcl_DStringAppend(&newName, symbol, -1);
	if (shl_findsym(&handle, Tcl_DStringValue(&newName),
		(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
	    proc = NULL;
	}
	Tcl_DStringFree(&newName);
    }

    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
    shl_t handle;

    handle = (shl_t) clientData;
    shl_unload(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --







|
|
|





|







141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    shl_t handle;

    handle = (shl_t) loadHandle;
    shl_unload(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
Changes to unix/tclUnixChan.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclUnixChan.c
 *
 *	Common channel driver for Unix channels based on files, command
 *	pipes and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixChan.c,v 1.21.8.2 2002/06/10 05:33:18 wolfsuit Exp $
 */

#include "tclInt.h"	/* Internal definitions for Tcl. */
#include "tclPort.h"	/* Portability features for Tcl. */

/*
 * sys/ioctl.h has already been included by tclPort.h.	Including termios.h












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclUnixChan.c
 *
 *	Common channel driver for Unix channels based on files, command
 *	pipes and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixChan.c,v 1.21.8.3 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"	/* Internal definitions for Tcl. */
#include "tclPort.h"	/* Portability features for Tcl. */

/*
 * sys/ioctl.h has already been included by tclPort.h.	Including termios.h
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
{
    FileState *fsPtr = (FileState *) instanceData;
    Tcl_WideInt oldLoc, newLoc;

    /*
     * Save our current place in case we need to roll-back the seek.
     */
    oldLoc = Tcl_PlatformSeek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
    if (oldLoc == Tcl_LongAsWide(-1)) {
	/*
	 * Bad things are happening.  Error out...
	 */
	*errorCodePtr = errno;
	return -1;
    }
 
    newLoc = Tcl_PlatformSeek(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;
	Tcl_PlatformSeek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
	return -1;
    } else {
	*errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
    }
    return (int) Tcl_WideAsLong(newLoc);
}








|








|






|







598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
{
    FileState *fsPtr = (FileState *) instanceData;
    Tcl_WideInt oldLoc, newLoc;

    /*
     * Save our current place in case we need to roll-back the seek.
     */
    oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
    if (oldLoc == Tcl_LongAsWide(-1)) {
	/*
	 * Bad things are happening.  Error out...
	 */
	*errorCodePtr = errno;
	return -1;
    }
 
    newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
 
    /*
     * Check for expressability in our return type, and roll-back otherwise.
     */
    if (newLoc > Tcl_LongAsWide(INT_MAX)) {
	*errorCodePtr = EOVERFLOW;
	TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
	return -1;
    } else {
	*errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
    }
    return (int) Tcl_WideAsLong(newLoc);
}

654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
    int mode;			/* Relative to where should we seek? Can be
				 * one of SEEK_START, SEEK_CUR or SEEK_END. */
    int *errorCodePtr;		/* To store error code. */
{
    FileState *fsPtr = (FileState *) instanceData;
    Tcl_WideInt newLoc;

    newLoc = Tcl_PlatformSeek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);

    *errorCodePtr = (newLoc == -1) ? errno : 0;
    return newLoc;
}

/*
 *----------------------------------------------------------------------







|







654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
    int mode;			/* Relative to where should we seek? Can be
				 * one of SEEK_START, SEEK_CUR or SEEK_END. */
    int *errorCodePtr;		/* To store error code. */
{
    FileState *fsPtr = (FileState *) instanceData;
    Tcl_WideInt newLoc;

    newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);

    *errorCodePtr = (newLoc == -1) ? errno : 0;
    return newLoc;
}

/*
 *----------------------------------------------------------------------
1742
1743
1744
1745
1746
1747
1748
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
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(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? */
{
    int fd, seekFlag, mode, channelPermissions;
    FileState *fsPtr;
    CONST char *native, *translation;
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_ChannelType *channelTypePtr;
#ifdef SUPPORTS_TTY
    int ctl_tty;
#endif /* SUPPORTS_TTY */
#ifdef DEPRECATED
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */

    mode = TclGetOpenMode(interp, modeString, &seekFlag);
    if (mode == -1) {
	return NULL;
    }
    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:
	    channelPermissions = TCL_READABLE;
	    break;
	case O_WRONLY:
	    channelPermissions = TCL_WRITABLE;
	    break;







|



|
<




|











<
<
<
<







1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753

1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769




1770
1771
1772
1773
1774
1775
1776
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
    Tcl_Interp *interp;			/* Interpreter for error reporting;
					 * can be NULL. */
    Tcl_Obj *pathPtr;			/* Name of file to open. */
    int mode;				/* POSIX open mode. */

    int permissions;			/* If the open involves creating a
					 * file, with what modes to create
					 * it? */
{
    int fd, channelPermissions;
    FileState *fsPtr;
    CONST char *native, *translation;
    char channelName[16 + TCL_INTEGER_SPACE];
    Tcl_ChannelType *channelTypePtr;
#ifdef SUPPORTS_TTY
    int ctl_tty;
#endif /* SUPPORTS_TTY */
#ifdef DEPRECATED
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */





    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:
	    channelPermissions = TCL_READABLE;
	    break;
	case O_WRONLY:
	    channelPermissions = TCL_WRITABLE;
	    break;
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
	    return NULL;
    }

    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	return NULL;
    }
    fd = Tcl_PlatformOpen(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 \"", 







|







1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
	    return NULL;
    }

    native = Tcl_FSGetNativePath(pathPtr);
    if (native == NULL) {
	return NULL;
    }
    fd = TclOSopen(native, mode, permissions);
#ifdef SUPPORTS_TTY
    ctl_tty = (strcmp (native, "/dev/tty") == 0);
#endif /* SUPPORTS_TTY */

    if (fd < 0) {
	if (interp != (Tcl_Interp *) NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"", 
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
#endif /* DEPRECATED */
    fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
    fsPtr->fd = fd;

    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    (ClientData) fsPtr, channelPermissions);

    if (seekFlag) {
	if (Tcl_Seek(fsPtr->channel, (Tcl_WideInt)0,
		SEEK_END) < (Tcl_WideInt)0) {
	    if (interp != (Tcl_Interp *) NULL) {
		Tcl_AppendResult(interp, "couldn't seek to end of file on \"",
			channelName, "\": ", Tcl_PosixError(interp), NULL);
	    }
	    Tcl_Close(NULL, fsPtr->channel);
	    return NULL;
	}
    }

    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.







<
<
<
<
<
<
<
<
<
<
<
<







1839
1840
1841
1842
1843
1844
1845












1846
1847
1848
1849
1850
1851
1852
#endif /* DEPRECATED */
    fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
    fsPtr->fd = fd;

    fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
	    (ClientData) fsPtr, channelPermissions);













    if (translation != NULL) {
	/*
	 * Gotcha.  Most modems need a "\r" at the end of the command
	 * sequence.  If you just send "at\n", the modem will not respond
	 * with "OK" because it never got a "\r" to actually invoke the
	 * command.  So, by default, newlines are translated to "\r\n" on
	 * output to avoid "bug" reports that the serial port isn't working.
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
    char channelName[16 + TCL_INTEGER_SPACE];
    int fd = (int) handle;
    Tcl_ChannelType *channelTypePtr;
#ifdef DEPRECATED
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
    int socketType = 0;
    size_t argLength = sizeof(int);

    if (mode == 0) {
	return NULL;
    }


    /*







|







1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
    char channelName[16 + TCL_INTEGER_SPACE];
    int fd = (int) handle;
    Tcl_ChannelType *channelTypePtr;
#ifdef DEPRECATED
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
    int socketType = 0;
    socklen_t argLength = sizeof(int);

    if (mode == 0) {
	return NULL;
    }


    /*
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
    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;
    size_t size = sizeof(struct sockaddr_in);
    size_t len = 0;
    char buf[TCL_INTEGER_SPACE];

    if (optionName != (char *) NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	size_t optlen = sizeof(int);
	int err, ret;

	ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR,
		(char *)&err, &optlen);
	if (ret < 0) {
	    err = errno;
	}







|









|







2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
    Tcl_DString *dsPtr;		 /* Where to store the computed
				  * value; initialized by caller. */
{
    TcpState *statePtr = (TcpState *) instanceData;
    struct sockaddr_in sockname;
    struct sockaddr_in peername;
    struct hostent *hostEntPtr;
    socklen_t size = sizeof(struct sockaddr_in);
    size_t len = 0;
    char buf[TCL_INTEGER_SPACE];

    if (optionName != (char *) NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&
	    (strncmp(optionName, "-error", len) == 0)) {
	socklen_t optlen = sizeof(int);
	int err, ret;

	ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR,
		(char *)&err, &optlen);
	if (ret < 0) {
	    err = errno;
	}
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
    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 */
    size_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) {







|







2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
    ClientData data;			/* Callback token. */
    int mask;				/* Not used. */
{
    TcpState *sockState;		/* Client data of server socket. */
    int newsock;			/* The new client socket */
    TcpState *newSockState;		/* State for new socket. */
    struct sockaddr_in addr;		/* The remote address */
    socklen_t len;				/* For accept interface */
    char channelName[16 + TCL_INTEGER_SPACE];

    sockState = (TcpState *) data;

    len = sizeof(struct sockaddr_in);
    newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len);
    if (newsock < 0) {
2950
2951
2952
2953
2954
2955
2956






2957
2958
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
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    Tcl_Channel channel = NULL;
    int fd = 0;			/* Initializations needed to prevent */
    int mode = 0;		/* compiler warning (used before set). */
    char *bufMode = NULL;







    switch (type) {
	case TCL_STDIN:
	    if ((Tcl_PlatformSeek(0, (Tcl_SeekOffset) 0,
		    SEEK_CUR) == (Tcl_SeekOffset)-1) && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 0;
	    mode = TCL_READABLE;
	    bufMode = "line";
	    break;
	case TCL_STDOUT:
	    if ((Tcl_PlatformSeek(1, (Tcl_SeekOffset) 0,
		    SEEK_CUR) == (Tcl_SeekOffset)-1) && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 1;
	    mode = TCL_WRITABLE;
	    bufMode = "line";
	    break;
	case TCL_STDERR:
	    if ((Tcl_PlatformSeek(2, (Tcl_SeekOffset) 0,
		    SEEK_CUR) == (Tcl_SeekOffset)-1) && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 2;
	    mode = TCL_WRITABLE;
	    bufMode = "none";
	    break;
	default:
	    panic("TclGetDefaultStdChannel: Unexpected channel type");
	    break;
    }




    channel = Tcl_MakeFileChannel((ClientData) fd, mode);
    if (channel == NULL) {
	return NULL;
    }

    /*
     * Set up the normal channel options for stdio handles.







>
>
>
>
>
>


|
|







|
|







|
|











>
>
>







2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
    int type;			/* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
    Tcl_Channel channel = NULL;
    int fd = 0;			/* Initializations needed to prevent */
    int mode = 0;		/* compiler warning (used before set). */
    char *bufMode = NULL;

    /*
     * Some #def's to make the code a little clearer!
     */
#define ZERO_OFFSET	((Tcl_SeekOffset) 0)
#define ERROR_OFFSET	((Tcl_SeekOffset) -1)

    switch (type) {
	case TCL_STDIN:
	    if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		    && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 0;
	    mode = TCL_READABLE;
	    bufMode = "line";
	    break;
	case TCL_STDOUT:
	    if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		    && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 1;
	    mode = TCL_WRITABLE;
	    bufMode = "line";
	    break;
	case TCL_STDERR:
	    if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
		    && (errno == EBADF)) {
		return (Tcl_Channel) NULL;
	    }
	    fd = 2;
	    mode = TCL_WRITABLE;
	    bufMode = "none";
	    break;
	default:
	    panic("TclGetDefaultStdChannel: Unexpected channel type");
	    break;
    }

#undef ZERO_OFFSET
#undef ERROR_OFFSET

    channel = Tcl_MakeFileChannel((ClientData) fd, mode);
    if (channel == NULL) {
	return NULL;
    }

    /*
     * Set up the normal channel options for stdio handles.
Changes to unix/tclUnixFCmd.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclUnixFCmd.c
 *
 *      This file implements the unix specific portion of file manipulation 
 *      subcommands of the "file" command.  All filename arguments should
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.13.2.3 2002/06/28 22:34:39 wolfsuit 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.
 *












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclUnixFCmd.c
 *
 *      This file implements the unix specific portion of file manipulation 
 *      subcommands of the "file" command.  All filename arguments should
 *	already be translated to native format.
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFCmd.c,v 1.13.2.4 2002/08/20 20:25:30 das Exp $
 *
 * Portions of this code were derived from NetBSD source code which has
 * the following copyright notice:
 *
 * Copyright (c) 1988, 1993, 1994
 *      The Regents of the University of California.  All rights reserved.
 *
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

	if ((Realpath((char *) src, srcPath) != NULL)	/* INTL: Native. */
		&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
		&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
	    dirPtr = opendir(dst);			/* INTL: Native. */
	    if (dirPtr != NULL) {
		while (1) {
		    dirEntPtr = Tcl_PlatformReaddir(dirPtr); /* INTL: Native. */
		    if (dirEntPtr == NULL) {
			break;
		    }
		    if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
			    (strcmp(dirEntPtr->d_name, "..") != 0)) {
			errno = EEXIST;
			closedir(dirPtr);







|







256
257
258
259
260
261
262
263
264
265
266
267
268
269
270

	if ((Realpath((char *) src, srcPath) != NULL)	/* INTL: Native. */
		&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
		&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
	    dirPtr = opendir(dst);			/* INTL: Native. */
	    if (dirPtr != NULL) {
		while (1) {
		    dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
		    if (dirEntPtr == NULL) {
			break;
		    }
		    if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
			    (strcmp(dirEntPtr->d_name, "..") != 0)) {
			errno = EEXIST;
			closedir(dirPtr);
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
{
    Tcl_StatBuf srcStatBuf, dstStatBuf;

    /*
     * Have to do a stat() to determine the filetype.
     */
    
    if (Tcl_PlatformLStat(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 (Tcl_PlatformLStat(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) {







|












|







340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
{
    Tcl_StatBuf srcStatBuf, dstStatBuf;

    /*
     * Have to do a stat() to determine the filetype.
     */
    
    if (TclOSlstat(src, &srcStatBuf) != 0) {		/* INTL: Native. */
	return TCL_ERROR;
    }
    if (S_ISDIR(srcStatBuf.st_mode)) {
	errno = EISDIR;
	return TCL_ERROR;
    }

    /*
     * symlink, and some of the other calls will fail if the target 
     * exists, so we remove it first
     */
    
    if (TclOSlstat(dst, &dstStatBuf) == 0) {		/* INTL: Native. */
	if (S_ISDIR(dstStatBuf.st_mode)) {
	    errno = EISDIR;
	    return TCL_ERROR;
	}
    }
    if (unlink(dst) != 0) {				/* INTL: Native. */
	if (errno != ENOENT) {
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
{
    int srcFd;
    int dstFd;
    u_int blockSize;   /* Optimal I/O blocksize for filesystem */
    char *buffer;      /* Data buffer for copy */
    size_t nread;

    if ((srcFd = Tcl_PlatformOpen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
	return TCL_ERROR;
    }

    dstFd = Tcl_PlatformOpen(dst,			/* INTL: Native. */
	    O_CREAT | O_TRUNC | O_WRONLY, statBufPtr->st_mode);
    if (dstFd < 0) {
	close(srcFd); 
	return TCL_ERROR;
    }

#ifdef HAVE_ST_BLKSIZE
    blockSize = statBufPtr->st_blksize;







|



|
|







434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
{
    int srcFd;
    int dstFd;
    u_int blockSize;   /* Optimal I/O blocksize for filesystem */
    char *buffer;      /* Data buffer for copy */
    size_t nread;

    if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) {	/* INTL: Native. */
	return TCL_ERROR;
    }

    dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY,	/* INTL: Native. */
	    statBufPtr->st_mode);
    if (dstFd < 0) {
	close(srcFd); 
	return TCL_ERROR;
    }

#ifdef HAVE_ST_BLKSIZE
    blockSize = statBufPtr->st_blksize;
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
    path = Tcl_DStringValue(pathPtr);
    
    if (recursive != 0) {
	/* We should try to change permissions so this can be deleted */
	Tcl_StatBuf statBuf;
	int newPerm;

	if (Tcl_PlatformStat(path, &statBuf) == 0) {
	    oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
	}
	
	newPerm = oldPerm | (64+128+256);
	chmod(path, (mode_t) newPerm);
    }
    







|







714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
    path = Tcl_DStringValue(pathPtr);
    
    if (recursive != 0) {
	/* We should try to change permissions so this can be deleted */
	Tcl_StatBuf statBuf;
	int newPerm;

	if (TclOSstat(path, &statBuf) == 0) {
	    oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
	}
	
	newPerm = oldPerm | (64+128+256);
	chmod(path, (mode_t) newPerm);
    }
    
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
    DIR *dirPtr;

    errfile = NULL;
    result = TCL_OK;
    targetLen = 0;		/* lint. */

    source = Tcl_DStringValue(sourcePtr);
    if (Tcl_PlatformLStat(source, &statBuf) != 0) {	/* INTL: Native. */
	errfile = source;
	goto end;
    }
    if (!S_ISDIR(statBuf.st_mode)) {
	/*
	 * Process the regular file
	 */







|







799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
    DIR *dirPtr;

    errfile = NULL;
    result = TCL_OK;
    targetLen = 0;		/* lint. */

    source = Tcl_DStringValue(sourcePtr);
    if (TclOSlstat(source, &statBuf) != 0) {		/* INTL: Native. */
	errfile = source;
	goto end;
    }
    if (!S_ISDIR(statBuf.st_mode)) {
	/*
	 * Process the regular file
	 */
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
    Tcl_DStringAppend(sourcePtr, "/", 1);
    sourceLen = Tcl_DStringLength(sourcePtr);	

    if (targetPtr != NULL) {
	Tcl_DStringAppend(targetPtr, "/", 1);
	targetLen = Tcl_DStringLength(targetPtr);
    }
				  
    while ((dirEntPtr = Tcl_PlatformReaddir(dirPtr)) != NULL) {	/* INTL: Native. */
	if ((strcmp(dirEntPtr->d_name, ".") == 0)
	        || (strcmp(dirEntPtr->d_name, "..") == 0)) {
	    continue;
	}

	/* 
	 * Append name after slash, and recurse on the file.







|
|







834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
    Tcl_DStringAppend(sourcePtr, "/", 1);
    sourceLen = Tcl_DStringLength(sourcePtr);	

    if (targetPtr != NULL) {
	Tcl_DStringAppend(targetPtr, "/", 1);
	targetLen = Tcl_DStringLength(targetPtr);
    }

    while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
	if ((strcmp(dirEntPtr->d_name, ".") == 0)
	        || (strcmp(dirEntPtr->d_name, "..") == 0)) {
	    continue;
	}

	/* 
	 * Append name after slash, and recurse on the file.
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *      Called from TraverseUnixTree in order to execute a recursive copy of a 
 *      directory. 
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      The file or directory src may be copied to dst, depending on 
 *      the value of type.







|
|







900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
}

/*
 *----------------------------------------------------------------------
 *
 * TraversalCopy
 *
 *      Called from TraverseUnixTree in order to execute a recursive copy
 *      of a directory.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      The file or directory src may be copied to dst, depending on 
 *      the value of type.
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    switch (type) {
	case DOTREE_F:
	    if (DoCopyFile(Tcl_DStringValue(srcPtr), 
			   Tcl_DStringValue(dstPtr)) == TCL_OK) {
		return TCL_OK;
	    }
	    break;

	case DOTREE_PRED:
	    if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
		return TCL_OK;







|







927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
    Tcl_DString *errorPtr;	/* If non-NULL, uninitialized or free
				 * DString filled with UTF-8 name of file
				 * causing error. */
{
    switch (type) {
	case DOTREE_F:
	    if (DoCopyFile(Tcl_DStringValue(srcPtr), 
		    Tcl_DStringValue(dstPtr)) == TCL_OK) {
		return TCL_OK;
	    }
	    break;

	case DOTREE_PRED:
	    if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
		return TCL_OK;
1671
1672
1673
1674
1675
1676
1677
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
#endif

    currentPathEndPosition = path + nextCheckpoint;

    while (1) {
	cur = *currentPathEndPosition;
	if ((cur == '/') && (path != currentPathEndPosition)) {
	    /* Reached directory separator, or end of string */
	    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) {

	    break;
	}
	currentPathEndPosition++;
    }
    /* 
     * We should really now convert this to a canonical path.  We do
     * that with 'realpath' if we have it available.  Otherwise we could
     * step through every single path component, checking whether it is a 
     * symlink, but that would be a lot of work, and most modern OSes 
     * have 'realpath'.
     */
#ifndef NO_REALPATH
    /* 
     * If we only had '/foo' or '/' then we never increment nextCheckpoint
     * and we don't need or want to go through 'Realpath'.  Also, on some
     * platforms, passing an empty string to 'Realpath' will give us the
     * normalized pwd, which is not what we want at all!
     */
    if (nextCheckpoint == 0) {
        return 0;
    }

    nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
    if (Realpath(nativePath, normPath) != NULL) {
	/* 
	 * Free up the native path and put in its place the
	 * converted, normalized path.
	 */
	Tcl_DStringFree(&ds);







|















>


















|
<
|
<







1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713

1714

1715
1716
1717
1718
1719
1720
1721
#endif

    currentPathEndPosition = path + nextCheckpoint;

    while (1) {
	cur = *currentPathEndPosition;
	if ((cur == '/') && (path != currentPathEndPosition)) {
	    /* Reached directory separator */
	    Tcl_DString ds;
	    CONST char *nativePath;
	    int accessOk;

	    nativePath = Tcl_UtfToExternalDString(NULL, path, 
		    currentPathEndPosition - path, &ds);
	    accessOk = access(nativePath, F_OK);
	    Tcl_DStringFree(&ds);
	    if (accessOk != 0) {
		/* File doesn't exist */
		break;
	    }
	    /* Update the acceptable point */
	    nextCheckpoint = currentPathEndPosition - path;
	} else if (cur == 0) {
	    /* Reached end of string */
	    break;
	}
	currentPathEndPosition++;
    }
    /* 
     * We should really now convert this to a canonical path.  We do
     * that with 'realpath' if we have it available.  Otherwise we could
     * step through every single path component, checking whether it is a 
     * symlink, but that would be a lot of work, and most modern OSes 
     * have 'realpath'.
     */
#ifndef NO_REALPATH
    /* 
     * If we only had '/foo' or '/' then we never increment nextCheckpoint
     * and we don't need or want to go through 'Realpath'.  Also, on some
     * platforms, passing an empty string to 'Realpath' will give us the
     * normalized pwd, which is not what we want at all!
     */
    if (nextCheckpoint == 0) return 0;

    

    nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
    if (Realpath(nativePath, normPath) != NULL) {
	/* 
	 * Free up the native path and put in its place the
	 * converted, normalized path.
	 */
	Tcl_DStringFree(&ds);
Changes to unix/tclUnixFile.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclUnixFile.c --
 *
 *      This file contains wrappers around UNIX file handling functions.
 *      These wrappers mask differences between Windows and UNIX.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFile.c,v 1.12.8.2 2002/06/10 05:33:18 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclUnixFile.c --
 *
 *      This file contains wrappers around UNIX file handling functions.
 *      These wrappers mask differences between Windows and UNIX.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixFile.c,v 1.12.8.3 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);

114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

	/*
	 * INTL: The following calls to access() and stat() should not be
	 * converted to Tclp routines because they need to operate on native
	 * strings directly.
	 */

	if ((access(name, X_OK) == 0)			   /* INTL: Native. */
		&& (Tcl_PlatformStat(name, &statBuf) == 0) /* INTL: Native. */
		&& S_ISREG(statBuf.st_mode)) {
	    goto gotName;
	}
	if (*p == '\0') {
	    break;
	} else if (*(p+1) == 0) {
	    p = "./";







|
|







114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

	/*
	 * INTL: The following calls to access() and stat() should not be
	 * converted to Tclp routines because they need to operate on native
	 * strings directly.
	 */

	if ((access(name, X_OK) == 0)			/* INTL: Native. */
		&& (TclOSstat(name, &statBuf) == 0)	/* INTL: Native. */
		&& S_ISREG(statBuf.st_mode)) {
	    goto gotName;
	}
	if (*p == '\0') {
	    break;
	} else if (*(p+1) == 0) {
	    p = "./";
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

	/*
	 * Now open the directory for reading and iterate over the contents.
	 */

	native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);

	if ((Tcl_PlatformStat(native, &statBuf) != 0)		/* INTL: UTF-8. */
		|| !S_ISDIR(statBuf.st_mode)) {
	    Tcl_DStringFree(&dsOrig);
	    Tcl_DStringFree(&ds);
	    return TCL_OK;
	}

	d = opendir(native);				/* INTL: Native. */







|







269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

	/*
	 * Now open the directory for reading and iterate over the contents.
	 */

	native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);

	if ((TclOSstat(native, &statBuf) != 0)		/* INTL: Native. */
		|| !S_ISDIR(statBuf.st_mode)) {
	    Tcl_DStringFree(&dsOrig);
	    Tcl_DStringFree(&ds);
	    return TCL_OK;
	}

	d = opendir(native);				/* INTL: Native. */
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
	nativeDirLen = Tcl_DStringLength(&ds);

	while (1) {
	    Tcl_DString utfDs;
	    CONST char *utf;
	    Tcl_DirEntry *entryPtr;
	    
	    entryPtr = Tcl_PlatformReaddir(d);		/* INTL: Native. */
	    if (entryPtr == NULL) {
		break;
	    }
	    if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
		/* 
		 * We explicitly asked for hidden files, so turn around
		 * and ignore any file which isn't hidden.







|







309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
	nativeDirLen = Tcl_DStringLength(&ds);

	while (1) {
	    Tcl_DString utfDs;
	    CONST char *utf;
	    Tcl_DirEntry *entryPtr;
	    
	    entryPtr = TclOSreaddir(d);			/* INTL: Native. */
	    if (entryPtr == NULL) {
		break;
	    }
	    if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
		/* 
		 * We explicitly asked for hidden files, so turn around
		 * and ignore any file which isn't hidden.
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
    if (types == NULL) {
	/* 
	 * Simply check for the file's existence, but do it
	 * with lstat, in case it is a link to a file which
	 * doesn't exist (since that case would not show up
	 * if we used 'access' or 'stat')
	 */
	if (Tcl_PlatformLStat(nativeEntry, &buf) != 0) {
	    return 0;
	}
    } else {
	if (types->perm != 0) {
	    if (Tcl_PlatformStat(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







|




|







374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
    if (types == NULL) {
	/* 
	 * Simply check for the file's existence, but do it
	 * with lstat, in case it is a link to a file which
	 * doesn't exist (since that case would not show up
	 * if we used 'access' or 'stat')
	 */
	if (TclOSlstat(nativeEntry, &buf) != 0) {
	    return 0;
	}
    } else {
	if (types->perm != 0) {
	    if (TclOSstat(nativeEntry, &buf) != 0) {
		/* 
		 * Either the file has disappeared between the
		 * 'readdir' call and the 'stat' call, or
		 * the file is a link to a file which doesn't
		 * exist (which we could ascertain with
		 * lstat), or there is some other strange
		 * problem.  In all these cases, we define this
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
		) {
		return 0;
	    }
	}
	if (types->type != 0) {
	    if (types->perm == 0) {
		/* We haven't yet done a stat on the file */
		if (Tcl_PlatformStat(nativeEntry, &buf) != 0) {
		    /* Posix error occurred */
		    return 0;
		}
	    }
	    /*
	     * In order bcdpfls as in 'find -t'
	     */
	    if (
		((types->type & TCL_GLOB_TYPE_BLOCK) &&
			S_ISBLK(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_CHAR) &&
			S_ISCHR(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_DIR) &&
			S_ISDIR(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_PIPE) &&
			S_ISFIFO(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_FILE) &&
			S_ISREG(buf.st_mode))
    #ifdef S_ISSOCK
		|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
			S_ISSOCK(buf.st_mode))
    #endif
		) {
		/* Do nothing -- this file is ok */
	    } else {
    #ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    if (Tcl_PlatformLStat(nativeEntry, &buf) == 0) {
			if (S_ISLNK(buf.st_mode)) {
			    return 1;
			}
		    }
		}
    #endif
		return 0;
	    }
	}
    }
    return 1;
}








|


















|


|



|

|





|







413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
		) {
		return 0;
	    }
	}
	if (types->type != 0) {
	    if (types->perm == 0) {
		/* We haven't yet done a stat on the file */
		if (TclOSstat(nativeEntry, &buf) != 0) {
		    /* Posix error occurred */
		    return 0;
		}
	    }
	    /*
	     * In order bcdpfls as in 'find -t'
	     */
	    if (
		((types->type & TCL_GLOB_TYPE_BLOCK) &&
			S_ISBLK(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_CHAR) &&
			S_ISCHR(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_DIR) &&
			S_ISDIR(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_PIPE) &&
			S_ISFIFO(buf.st_mode)) ||
		((types->type & TCL_GLOB_TYPE_FILE) &&
			S_ISREG(buf.st_mode))
#ifdef S_ISSOCK
		|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
			S_ISSOCK(buf.st_mode))
#endif /* S_ISSOCK */
		) {
		/* Do nothing -- this file is ok */
	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    if (TclOSlstat(nativeEntry, &buf) == 0) {
			if (S_ISLNK(buf.st_mode)) {
			    return 1;
			}
		    }
		}
#endif /* S_ISLNK */
		return 0;
	    }
	}
    }
    return 1;
}

577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
 */

int 
TclpObjLstat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    return Tcl_PlatformLStat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjGetCwd --
 *







|







577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
 */

int 
TclpObjLstat(pathPtr, bufPtr)
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpObjGetCwd --
 *
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
#else
	return NULL;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjStat --







|







683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
#else
    return NULL;
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclpObjStat --
712
713
714
715
716
717
718
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
    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 Tcl_PlatformStat(path, bufPtr);
    }
}


#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;

{



    Tcl_Obj* linkPtr = NULL;






    if (toPtr != NULL) {




        return NULL;









    } else {







	char link[MAXPATHLEN];
	int length;
	char *native;


	if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) {
	    return NULL;
	}
	length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
	if (length < 0) {
	    return NULL;
	}
	
	/* 
	 * Allocate and copy the name, taking care since the
	 * name need not be null terminated. 
	 */
	native = (char*)ckalloc((unsigned)(1+length));
	strncpy(native, link, (unsigned)length);
	native[length] = '\0';
	

	linkPtr = Tcl_FSNewNativePath(pathPtr, native);



	Tcl_IncrRefCount(linkPtr);
    }
    return linkPtr;

}

#endif


/*
 *---------------------------------------------------------------------------







|







|


>

>
>
>
|
>
>
|
>
>
>
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>



>
|
















>
|
>
>
>
|
|
|
>







712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
    Tcl_Obj *pathPtr;		/* Path of file to stat */
    Tcl_StatBuf *bufPtr;	/* Filled with results of stat call. */
{
    CONST char *path = Tcl_FSGetNativePath(pathPtr);
    if (path == NULL) {
	return -1;
    } else {
	return TclOSstat(path, bufPtr);
    }
}


#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    if (toPtr != NULL) {
	CONST char *src = Tcl_FSGetNativePath(pathPtr);
	CONST char *target = Tcl_FSGetNativePath(toPtr);
	
	if (src == NULL || target == NULL) {
	    return NULL;
	}
	if (access(src, F_OK) != -1) {
	    /* src exists */
	    errno = EEXIST;
	    return NULL;
	}
	if (access(target, F_OK) == -1) {
	    /* target doesn't exist */
	    errno = ENOENT;
	    return NULL;
	}
	/* 
	 * Check symbolic link flag first, since we prefer to
	 * create these.
	 */
	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    if (symlink(target, src) != 0) return NULL;
	} else if (linkAction & TCL_CREATE_HARD_LINK) {
	    if (link(target, src) != 0) return NULL;
	} else {
	    errno = ENODEV;
	    return NULL;
	}
	return toPtr;
    } else {
	Tcl_Obj* linkPtr = NULL;

	char link[MAXPATHLEN];
	int length;
	char *native;
	Tcl_DString ds;
	
	if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) {
	    return NULL;
	}
	length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
	if (length < 0) {
	    return NULL;
	}
	
	/* 
	 * Allocate and copy the name, taking care since the
	 * name need not be null terminated. 
	 */
	native = (char*)ckalloc((unsigned)(1+length));
	strncpy(native, link, (unsigned)length);
	native[length] = '\0';
	
	Tcl_ExternalToUtfDString(NULL, native, length, &ds);
	linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), 
				   Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	if (linkPtr != NULL) {
	    Tcl_IncrRefCount(linkPtr);
	}
	return linkPtr;
    }
}

#endif


/*
 *---------------------------------------------------------------------------
Changes to unix/tclUnixInit.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
/* 
 * tclUnixInit.c --
 *
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.24.8.4 2002/06/10 05:33:18 wolfsuit Exp $
 */

#if defined(HAVE_CFBUNDLE)
#include <CoreFoundation/CoreFoundation.h>
#endif
#include "tclInt.h"
#include "tclPort.h"









|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
/* 
 * tclUnixInit.c --
 *
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * All rights reserved.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.24.8.5 2002/08/20 20:25:30 das Exp $
 */

#if defined(HAVE_CFBUNDLE)
#include <CoreFoundation/CoreFoundation.h>
#endif
#include "tclInt.h"
#include "tclPort.h"
135
136
137
138
139
140
141



142
143
144
145
146
147
148
    {"ru_RU",		"iso8859-5"},		
    {"ru_SU",		"iso8859-5"},		

    {"zh",		"cp936"},

    {NULL, NULL}
};




/*
 *---------------------------------------------------------------------------
 *
 * TclpInitPlatform --
 *
 *	Initialize all the platform-dependant things like signals and







>
>
>







135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
    {"ru_RU",		"iso8859-5"},		
    {"ru_SU",		"iso8859-5"},		

    {"zh",		"cp936"},

    {NULL, NULL}
};

static int Tcl_MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath);


/*
 *---------------------------------------------------------------------------
 *
 * TclpInitPlatform --
 *
 *	Initialize all the platform-dependant things like signals and
393
394
395
396
397
398
399









400

401
402
403

404
405
406
407
408
409
410

    /*
     * 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.
     */
			      









    str = defaultLibraryDir;

    if (str[0] != '\0') {
        objPtr = Tcl_NewStringObj(str, -1);
        Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);

    }

    TclSetLibraryPath(pathPtr);    
    Tcl_DStringFree(&buffer);
}

/*







>
>
>
>
>
>
>
>
>
|
>



>







396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424

    /*
     * Finally, look for the library relative to the compiled-in path.
     * This is needed when users install Tcl with an exec-prefix that
     * is different from the prtefix.
     */
			      
    {
#ifdef HAVE_CFBUNDLE
    char tclLibPath[1024];
    
    if (Tcl_MacOSXGetLibraryPath(NULL, 1024, tclLibPath) == TCL_OK) {
        str = tclLibPath;
    } else
#endif /* HAVE_CFBUNDLE */  
    {
        str = defaultLibraryDir;
    }
    if (str[0] != '\0') {
        objPtr = Tcl_NewStringObj(str, -1);
        Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
    }
    }

    TclSetLibraryPath(pathPtr);    
    Tcl_DStringFree(&buffer);
}

/*
680
681
682
683
684
685
686
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
    struct utsname name;
#endif
    int unameOK;
    CONST char *user;
    Tcl_DString ds;

#ifdef HAVE_CFBUNDLE
    /*
     * If we have a bundle structure for the Tcl installation,
     * then check there first to see if we can find the libraries
     * there.
     */
     
    int foundInFramework = 0;
    char tclLibPath[1024];
    
    if (strcmp(defaultLibraryDir, "@TCL_IN_FRAMEWORK@") == 0) {
    
        foundInFramework = Tcl_MacOSXOpenBundleResources(interp, 
                "com.tcltk.tcllibrary",
                0, 1024, tclLibPath);
    }
    
    if (foundInFramework == TCL_OK) {
        Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, 
                TCL_GLOBAL_ONLY);
        Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
    } else {
#endif /* HAVE_CFBUNDLE */    

        Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir, 
                TCL_GLOBAL_ONLY);
        Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
        
#ifdef HAVE_CFBUNDLE
    }
#endif /* HAVE_CFBUNDLE */
#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







<
<
<
<
<
<
<


<
<
<
<
|
<
<
<



|
|
|



|
<
|
<







694
695
696
697
698
699
700







701
702




703



704
705
706
707
708
709
710
711
712
713

714

715
716
717
718
719
720
721
    struct utsname name;
#endif
    int unameOK;
    CONST char *user;
    Tcl_DString ds;

#ifdef HAVE_CFBUNDLE







    char tclLibPath[1024];
    




    if (Tcl_MacOSXGetLibraryPath(interp, 1024, tclLibPath) == TCL_OK) {



        Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath, 
                TCL_GLOBAL_ONLY);
        Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
    } else
#endif /* HAVE_CFBUNDLE */
    {
        Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir, 
                TCL_GLOBAL_ONLY);
        Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
    }



#ifdef DJGPP
    Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
    Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
    unameOK = 0;
#ifndef NO_UNAME
958
959
960
961
962
963
964
































{
    /*
     * This function is unimplemented on Unix platforms.
     */

    return 1;
}







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
{
    /*
     * This function is unimplemented on Unix platforms.
     */

    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MacOSXGetLibraryPath --
 *
 *	If we have a bundle structure for the Tcl installation,
 *	then check there first to see if we can find the libraries
 *	there.
 *
 * Results:
 *	TCL_OK if we have found the tcl library; TCL_ERROR otherwise.
 *
 * Side effects:
 *	Same as for Tcl_MacOSXOpenBundleResources.
 *
 *----------------------------------------------------------------------
 */
int Tcl_MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath)
{
	int foundInFramework = TCL_ERROR;
#ifdef HAVE_CFBUNDLE
    if (strcmp(defaultLibraryDir, "@TCL_IN_FRAMEWORK@") == 0) {
    
        foundInFramework = Tcl_MacOSXOpenBundleResources(interp, 
                "com.tcltk.tcllibrary",
                0, maxPathLen, tclLibPath);
    }
#endif	
	return foundInFramework;
}

Changes to unix/tclUnixNotfy.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclUnixNotify.c --
 *
 *	This file contains the implementation of the select-based
 *	Unix-specific notifier, which is the lowest-level part of the
 *	Tcl event loop.  This file works together with
 *	../generic/tclNotify.c.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixNotfy.c,v 1.10.18.1 2001/10/15 09:13:49 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <signal.h> 

extern TclStubs tclStubs;













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclUnixNotify.c --
 *
 *	This file contains the implementation of the select-based
 *	Unix-specific notifier, which is the lowest-level part of the
 *	Tcl event loop.  This file works together with
 *	../generic/tclNotify.c.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixNotfy.c,v 1.10.18.2 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <signal.h> 

extern TclStubs tclStubs;
Changes to unix/tclUnixPipe.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclUnixPipe.c --
 *
 *	This file implements the UNIX-specific exec pipeline functions,
 *	the "pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPipe.c,v 1.15.8.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The following macros convert between TclFile's and fd's.  The conversion












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/* 
 * tclUnixPipe.c --
 *
 *	This file implements the UNIX-specific exec pipeline functions,
 *	the "pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPipe.c,v 1.15.8.3 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The following macros convert between TclFile's and fd's.  The conversion
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
    int mode;			/* In what mode to open the file? */
{
    int fd;
    CONST char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
    fd = Tcl_PlatformOpen(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) {
	    Tcl_PlatformSeek(fd, (Tcl_SeekOffset) 0, SEEK_END);
	}

	/*
	 * Increment the fd so it can't be 0, which would conflict with
	 * the NULL return for errors.
	 */








|










|







136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
    int mode;			/* In what mode to open the file? */
{
    int fd;
    CONST char *native;
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
    fd = TclOSopen(native, mode, 0666);			/* INTL: Native. */
    Tcl_DStringFree(&ds);
    if (fd != -1) {
        fcntl(fd, F_SETFD, FD_CLOEXEC);

	/*
	 * If the file is being opened for writing, seek to the end
	 * so we can append to any data already in the file.
	 */

	if (mode & O_WRONLY) {
	    TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
	}

	/*
	 * Increment the fd so it can't be 0, which would conflict with
	 * the NULL return for errors.
	 */

211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
	native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
	if (write(fd, native, strlen(native)) == -1) {
	    close(fd);
	    Tcl_DStringFree(&dstring);
	    return NULL;
	}
	Tcl_DStringFree(&dstring);
	Tcl_PlatformSeek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
    }
    return MakeFile(fd);
}

/*
 *----------------------------------------------------------------------
 *







|







211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
	native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
	if (write(fd, native, strlen(native)) == -1) {
	    close(fd);
	    Tcl_DStringFree(&dstring);
	    return NULL;
	}
	Tcl_DStringFree(&dstring);
	TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
    }
    return MakeFile(fd);
}

/*
 *----------------------------------------------------------------------
 *
Changes to unix/tclUnixPort.h.
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPort.h,v 1.18.8.1 2002/06/10 05:33:19 wolfsuit Exp $
 */

#ifndef _TCLUNIXPORT
#define _TCLUNIXPORT

#ifndef _TCLINT
#   include "tclInt.h"







|







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixPort.h,v 1.18.8.2 2002/08/20 20:25:30 das Exp $
 */

#ifndef _TCLUNIXPORT
#define _TCLUNIXPORT

#ifndef _TCLINT
#   include "tclInt.h"
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
#else
#   include <dirent.h>
#endif
#endif

#ifdef HAVE_STRUCT_DIRENT64
typedef struct dirent64	Tcl_DirEntry;
#   define Tcl_PlatformReaddir		readdir64
#   define Tcl_PlatformReaddir_r	readdir64_r
#else
typedef struct dirent	Tcl_DirEntry;
#   define Tcl_PlatformReaddir		readdir
#   define Tcl_PlatformReaddir_r	readdir_r
#endif

#ifdef HAVE_TYPE_OFF64_T
typedef off64_t		Tcl_SeekOffset;
#   define Tcl_PlatformSeek		lseek64
#   define Tcl_PlatformOpen		open64
#else
typedef off_t		Tcl_SeekOffset;
#   define Tcl_PlatformSeek		lseek
#   define Tcl_PlatformOpen		open
#endif

#ifdef HAVE_STRUCT_STAT64
#   define Tcl_PlatformStat		stat64
#   define Tcl_PlatformLStat		lstat64
#else
#   define Tcl_PlatformStat		stat
#   define Tcl_PlatformLStat		lstat
#endif

#if !HAVE_STRTOLL && defined(TCL_WIDE_INT_TYPE) && !TCL_WIDE_INT_IS_LONG
EXTERN Tcl_WideInt	strtoll _ANSI_ARGS_((CONST char *string,
					     char **endPtr, int base));
EXTERN Tcl_WideUInt	strtoull _ANSI_ARGS_((CONST char *string,
					      char **endPtr, int base));







|
|


|
|




|
|


|
|



|
|

|
|







55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
#else
#   include <dirent.h>
#endif
#endif

#ifdef HAVE_STRUCT_DIRENT64
typedef struct dirent64	Tcl_DirEntry;
#   define TclOSreaddir		readdir64
#   define TclOSreaddir_r	readdir64_r
#else
typedef struct dirent	Tcl_DirEntry;
#   define TclOSreaddir		readdir
#   define TclOSreaddir_r	readdir_r
#endif

#ifdef HAVE_TYPE_OFF64_T
typedef off64_t		Tcl_SeekOffset;
#   define TclOSseek		lseek64
#   define TclOSopen		open64
#else
typedef off_t		Tcl_SeekOffset;
#   define TclOSseek		lseek
#   define TclOSopen		open
#endif

#ifdef HAVE_STRUCT_STAT64
#   define TclOSstat		stat64
#   define TclOSlstat		lstat64
#else
#   define TclOSstat		stat
#   define TclOSlstat		lstat
#endif

#if !HAVE_STRTOLL && defined(TCL_WIDE_INT_TYPE) && !TCL_WIDE_INT_IS_LONG
EXTERN Tcl_WideInt	strtoll _ANSI_ARGS_((CONST char *string,
					     char **endPtr, int base));
EXTERN Tcl_WideUInt	strtoull _ANSI_ARGS_((CONST char *string,
					      char **endPtr, int base));
320
321
322
323
324
325
326

327
328
329
330
331
332
333
334
335
336

/*
 * On systems without symbolic links (i.e. S_IFLNK isn't defined)
 * define "lstat" to use "stat" instead.
 */

#ifndef S_IFLNK

#   define lstat	stat
#   define lstat64	stat64
#   define Tcl_PlatformLStat	Tcl_PlatformStat
#endif

/*
 * Define macros to query file type bits, if they're not already
 * defined.
 */








>


|







320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

/*
 * On systems without symbolic links (i.e. S_IFLNK isn't defined)
 * define "lstat" to use "stat" instead.
 */

#ifndef S_IFLNK
#   undef TclOSlstat
#   define lstat	stat
#   define lstat64	stat64
#   define TclOSlstat	TclOSstat
#endif

/*
 * Define macros to query file type bits, if they're not already
 * defined.
 */

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
EXTERN struct tm *     	TclpLocaltime(time_t *);
EXTERN struct tm *     	TclpGmtime(time_t *);
EXTERN char *          	TclpInetNtoa(struct in_addr);
#define readdir(x)	TclpReaddir(x)
#define localtime(x)	TclpLocaltime(x)
#define gmtime(x)	TclpGmtime(x)
#define inet_ntoa(x)	TclpInetNtoa(x)
#undef Tcl_PlatformReaddir
#define Tcl_PlatformReaddir(x) TclpReaddir(x)
#else
typedef int TclpMutex;
#define	TclpMutexInit(a)
#define	TclpMutexLock(a)
#define	TclpMutexUnlock(a)
#endif /* TCL_THREADS */

#include "tclPlatDecls.h"
#include "tclIntPlatDecls.h"

#endif /* _TCLUNIXPORT */







|
|











557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
EXTERN struct tm *     	TclpLocaltime(time_t *);
EXTERN struct tm *     	TclpGmtime(time_t *);
EXTERN char *          	TclpInetNtoa(struct in_addr);
#define readdir(x)	TclpReaddir(x)
#define localtime(x)	TclpLocaltime(x)
#define gmtime(x)	TclpGmtime(x)
#define inet_ntoa(x)	TclpInetNtoa(x)
#undef TclOSreaddir
#define TclOSreaddir(x) TclpReaddir(x)
#else
typedef int TclpMutex;
#define	TclpMutexInit(a)
#define	TclpMutexLock(a)
#define	TclpMutexUnlock(a)
#endif /* TCL_THREADS */

#include "tclPlatDecls.h"
#include "tclIntPlatDecls.h"

#endif /* _TCLUNIXPORT */
Changes to unix/tclUnixTest.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclUnixTest.c --
 *
 *	Contains platform specific test commands for the Unix platform.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixTest.c,v 1.11 1999/10/13 00:32:50 hobbs Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The headers are needed for the testalarm command that verifies the











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclUnixTest.c --
 *
 *	Contains platform specific test commands for the Unix platform.
 *
 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixTest.c,v 1.11.18.1 2002/08/20 20:25:30 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The headers are needed for the testalarm command that verifies the
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
/*
 * Forward declarations of procedures defined later in this file:
 */

static void		TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
			    int mask));
static int		TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
int			TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
static int		TestalarmCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static int		TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, char **argv));
static void 		AlarmHandler _ANSI_ARGS_(());

/*
 *----------------------------------------------------------------------
 *
 * TclplatformtestInit --
 *







|

|

|

|

|

|


|

|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
/*
 * Forward declarations of procedures defined later in this file:
 */

static void		TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
			    int mask));
static int		TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
int			TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
static int		TestalarmCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static int		TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
			    Tcl_Interp *interp, int argc, CONST char **argv));
static void 		AlarmHandler _ANSI_ARGS_(());

/*
 *----------------------------------------------------------------------
 *
 * TclplatformtestInit --
 *
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
 */

static int
TestfilehandlerCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Pipe *pipePtr;
    int i, mask, timeout;
    static int initialized = 0;
    char buffer[4000];
    TclFile file;








|







143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
 */

static int
TestfilehandlerCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Pipe *pipePtr;
    int i, mask, timeout;
    static int initialized = 0;
    char buffer[4000];
    TclFile file;

295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
	TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
    } else if (strcmp(argv[1], "oneevent") == 0) {
	Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
    } else if (strcmp(argv[1], "wait") == 0) {
	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
                    argv[0], " wait index readable/writable timeout\"",
                    (char *) NULL);
	    return TCL_ERROR;
	}
	if (pipePtr->readFile == NULL) {
	    Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
		    (char *) NULL);
	    return TCL_ERROR;







|







295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
	TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
	Tcl_SetResult(interp, buf, TCL_VOLATILE);
    } else if (strcmp(argv[1], "oneevent") == 0) {
	Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
    } else if (strcmp(argv[1], "wait") == 0) {
	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # arguments: should be \"",
                    argv[0], " wait index readable|writable timeout\"",
                    (char *) NULL);
	    return TCL_ERROR;
	}
	if (pipePtr->readFile == NULL) {
	    Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
		    (char *) NULL);
	    return TCL_ERROR;
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
 */

static int
TestfilewaitCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int mask, result, timeout;
    Tcl_Channel channel;
    int fd;
    ClientData data;

    if (argc != 4) {







|







370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
 */

static int
TestfilewaitCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    int mask, result, timeout;
    Tcl_Channel channel;
    int fd;
    ClientData data;

    if (argc != 4) {
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
 */

static int
TestfindexecutableCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *oldName;
    char *oldNativeName;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		" argv0\"", (char *) NULL);







|







439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
 */

static int
TestfindexecutableCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    char *oldName;
    char *oldNativeName;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
		" argv0\"", (char *) NULL);
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
 */

static int
TestgetopenfileCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    ClientData filePtr;

    if (argc != 3) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                " channelName forWriting\"",







|







493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
 */

static int
TestgetopenfileCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    ClientData filePtr;

    if (argc != 3) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                " channelName forWriting\"",
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
 */

static int
TestsetdefencdirCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                " defaultDir\"",
                (char *) NULL);
        return TCL_ERROR;







|







538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
 */

static int
TestsetdefencdirCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 2) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                " defaultDir\"",
                (char *) NULL);
        return TCL_ERROR;
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
 */

static int
TestgetdefencdirCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    if (argc != 1) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                (char *) NULL);
        return TCL_ERROR;
    }







|







582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
 */

static int
TestgetdefencdirCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    if (argc != 1) {
        Tcl_AppendResult(interp,
                "wrong # args: should be \"", argv[0],
                (char *) NULL);
        return TCL_ERROR;
    }
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
 */

static int
TestalarmCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
#ifdef SA_RESTART
    unsigned int sec;
    struct sigaction action;

    if (argc > 1) {
	Tcl_GetInt(interp, argv[1], (int *)&sec);







|







619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
 */

static int
TestalarmCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
#ifdef SA_RESTART
    unsigned int sec;
    struct sigaction action;

    if (argc > 1) {
	Tcl_GetInt(interp, argv[1], (int *)&sec);
696
697
698
699
700
701
702
703
704
705
706
707
708
 */

static int
TestgotsigCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, gotsig, (char *) NULL);
    gotsig = "0";
    return TCL_OK;
}







|





696
697
698
699
700
701
702
703
704
705
706
707
708
 */

static int
TestgotsigCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    Tcl_AppendResult(interp, gotsig, (char *) NULL);
    gotsig = "0";
    return TCL_OK;
}
Changes to unix/tclUnixThrd.c.
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS:  @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12
 */

#include "tclInt.h"


#ifdef TCL_THREADS

#include "tclPort.h"
#include "pthread.h"

typedef struct ThreadSpecificData {
    char	    	nabuf[16];
    struct tm   	gtbuf;
    struct tm   	ltbuf;
    struct {







>



<







9
10
11
12
13
14
15
16
17
18
19

20
21
22
23
24
25
26
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS:  @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12
 */

#include "tclInt.h"
#include "tclPort.h"

#ifdef TCL_THREADS


#include "pthread.h"

typedef struct ThreadSpecificData {
    char	    	nabuf[16];
    struct tm   	gtbuf;
    struct tm   	ltbuf;
    struct {
768
769
770
771
772
773
774

775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
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
    pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
    if (pcondPtr != NULL) {
	pthread_cond_destroy(pcondPtr);
	ckfree((char *)pcondPtr);
	*condPtr = NULL;
    }
}


/*
 *----------------------------------------------------------------------
 *
 * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
 *
 *	These procedures replace core C versions to be used in a
 *	threaded environment.
 *
 * Results:
 *	See documentation of C functions.
 *
 * Side effects:
 *	See documentation of C functions.
 *
 *----------------------------------------------------------------------
 */

#ifndef HAVE_READDIR_R
TCL_DECLARE_MUTEX( rdMutex )
#undef readdir
#endif

Tcl_DirEntry *
TclpReaddir(DIR * dir)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    Tcl_DirEntry *ent;



#ifdef HAVE_READDIR_R
    ent = &tsdPtr->rdbuf.ent; 
    if (Tcl_PlatformReaddir_r(dir, ent, &ent) != 0) {
	ent = NULL;
    }
#else


    Tcl_MutexLock( &rdMutex );
#ifdef HAVE_STRUCT_DIRENT64
    ent = readdir64(dir);
#else
    ent = readdir(dir);
#endif
    if(ent != NULL) {
    	memcpy( (VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent,
    		sizeof (Tcl_DirEntry) + sizeof (char) * (PATH_MAX+1) );
    	ent = &tsdPtr->rdbuf.ent;     
    }
    Tcl_MutexUnlock( &rdMutex );








#endif
    return ent;
}

#if !defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R)
TCL_DECLARE_MUTEX( tmMutex )
#undef localtime
#undef gmtime
#endif

struct tm *
TclpLocaltime(time_t * clock)
{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_LOCALTIME_R
    return localtime_r(clock, &tsdPtr->ltbuf);
#else
    Tcl_MutexLock( &tmMutex );
    memcpy( (VOID *) &tsdPtr->ltbuf, (VOID *) localtime( clock ), sizeof (struct tm) );
    Tcl_MutexUnlock( &tmMutex );
	return &tsdPtr->ltbuf;
#endif    



}

struct tm *
TclpGmtime(time_t * clock)
{

    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_GMTIME_R
    return gmtime_r(clock, &tsdPtr->gtbuf);
#else
    Tcl_MutexLock( &tmMutex );
    memcpy( (VOID *) &tsdPtr->gtbuf, (VOID *) gmtime( clock ), sizeof (struct tm) );
    Tcl_MutexUnlock( &tmMutex );
    return &tsdPtr->gtbuf;
#endif    



}

char *
TclpInetNtoa(struct in_addr addr)
{

    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;



}


/*
 * Additions by AOL for specialized thread memory allocator.
 */
#ifdef USE_THREAD_ALLOC
static int initialized = 0;
static pthread_key_t	key;
static pthread_once_t	once = PTHREAD_ONCE_INIT;







>


















|







<

>
>



|


|
>
>
|
|

|

|
|
|
|
|

|
>
>
>
>
>
>
>
>




|








>








|

>
>
>





>










>
>
>





>









>
>
>


>







768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801

802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
    pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
    if (pcondPtr != NULL) {
	pthread_cond_destroy(pcondPtr);
	ckfree((char *)pcondPtr);
	*condPtr = NULL;
    }
}
#endif /* TCL_THREADS */

/*
 *----------------------------------------------------------------------
 *
 * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
 *
 *	These procedures replace core C versions to be used in a
 *	threaded environment.
 *
 * Results:
 *	See documentation of C functions.
 *
 * Side effects:
 *	See documentation of C functions.
 *
 *----------------------------------------------------------------------
 */

#if defined(TCL_THREADS) && !defined(HAVE_READDIR_R)
TCL_DECLARE_MUTEX( rdMutex )
#undef readdir
#endif

Tcl_DirEntry *
TclpReaddir(DIR * dir)
{

    Tcl_DirEntry *ent;
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_READDIR_R
    ent = &tsdPtr->rdbuf.ent; 
    if (TclOSreaddir_r(dir, ent, &ent) != 0) {
	ent = NULL;
    }

#else /* !HAVE_READDIR_R */

    Tcl_MutexLock(&rdMutex);
#   ifdef HAVE_STRUCT_DIRENT64
    ent = readdir64(dir);
#   else /* !HAVE_STRUCT_DIRENT64 */
    ent = readdir(dir);
#   endif /* HAVE_STRUCT_DIRENT64 */
    if (ent != NULL) {
	memcpy((VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent,
		sizeof(Tcl_DirEntry) + sizeof(char) * (PATH_MAX+1));
	ent = &tsdPtr->rdbuf.ent;
    }
    Tcl_MutexUnlock(&rdMutex);

#endif /* HAVE_READDIR_R */
#else
#   ifdef HAVE_STRUCT_DIRENT64
    ent = readdir64(dir);
#   else /* !HAVE_STRUCT_DIRENT64 */
    ent = readdir(dir);
#   endif /* HAVE_STRUCT_DIRENT64 */
#endif
    return ent;
}

#if defined(TCL_THREADS) && (!defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R))
TCL_DECLARE_MUTEX( tmMutex )
#undef localtime
#undef gmtime
#endif

struct tm *
TclpLocaltime(time_t * clock)
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_LOCALTIME_R
    return localtime_r(clock, &tsdPtr->ltbuf);
#else
    Tcl_MutexLock( &tmMutex );
    memcpy( (VOID *) &tsdPtr->ltbuf, (VOID *) localtime( clock ), sizeof (struct tm) );
    Tcl_MutexUnlock( &tmMutex );
    return &tsdPtr->ltbuf;
#endif    
#else
    return localtime(clock);
#endif
}

struct tm *
TclpGmtime(time_t * clock)
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

#ifdef HAVE_GMTIME_R
    return gmtime_r(clock, &tsdPtr->gtbuf);
#else
    Tcl_MutexLock( &tmMutex );
    memcpy( (VOID *) &tsdPtr->gtbuf, (VOID *) gmtime( clock ), sizeof (struct tm) );
    Tcl_MutexUnlock( &tmMutex );
    return &tsdPtr->gtbuf;
#endif    
#else
    return gmtime(clock);
#endif
}

char *
TclpInetNtoa(struct in_addr addr)
{
#ifdef TCL_THREADS
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    union {
    	unsigned long l;
    	unsigned char b[4];
    } u;
    
    u.l = (unsigned long) addr.s_addr;
    sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", u.b[0], u.b[1], u.b[2], u.b[3]);
    return tsdPtr->nabuf;
#else
    return inet_ntoa(addr);
#endif
}

#ifdef TCL_THREADS
/*
 * Additions by AOL for specialized thread memory allocator.
 */
#ifdef USE_THREAD_ALLOC
static int initialized = 0;
static pthread_key_t	key;
static pthread_once_t	once = PTHREAD_ONCE_INIT;
Changes to unix/tclUnixTime.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
/* 
 * tclUnixTime.c --
 *
 *	Contains Unix specific versions of Tcl functions that
 *	obtain time values from the operating system.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixTime.c,v 1.11.12.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#include "tclInt.h"
#include "tclPort.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.
 */

Tcl_ThreadDataKey tmKey;

/*
 * If we fall back on the thread-unsafe versions of gmtime and localtime,
 * use this mutex to try to protect them.
 */

#if !defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R)
TCL_DECLARE_MUTEX( tmMutex )
#endif

/*
 * Forward declarations for procedures defined later in this file.
 */

static struct tm *ThreadSafeGMTime _ANSI_ARGS_(( CONST time_t* ));











|




>









|







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
/* 
 * tclUnixTime.c --
 *
 *	Contains Unix specific versions of Tcl functions that
 *	obtain time values from the operating system.
 *
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixTime.c,v 1.11.12.3 2002/08/20 20:25:31 das Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
#define TM_YEAR_BASE 1900
#define IsLeapYear(x)   ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))

/*
 * TclpGetDate is coded to return a pointer to a 'struct tm'.  For
 * thread safety, this structure must be in thread-specific data.
 * The 'tmKey' variable is the key to this buffer.
 */

static Tcl_ThreadDataKey tmKey;

/*
 * If we fall back on the thread-unsafe versions of gmtime and localtime,
 * use this mutex to try to protect them.
 */

#if !defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R)
TCL_DECLARE_MUTEX(tmMutex)
#endif

/*
 * Forward declarations for procedures defined later in this file.
 */

static struct tm *ThreadSafeGMTime _ANSI_ARGS_(( CONST time_t* ));
328
329
330
331
332
333
334

335
336
337
338
339
340
341
	sprintf(s, "Stardate %2d%03d.%01d",
		(((t->tm_year + TM_YEAR_BASE) + 377) - 2323),
		(((t->tm_yday + 1) * 1000) /
			(365 + IsLeapYear((t->tm_year + TM_YEAR_BASE)))),
		(((t->tm_hour * 60) + t->tm_min)/144));
	return(strlen(s));
    }

    return strftime(s, maxsize, format, t);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSafeGMTime --







>







329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
	sprintf(s, "Stardate %2d%03d.%01d",
		(((t->tm_year + TM_YEAR_BASE) + 377) - 2323),
		(((t->tm_yday + 1) * 1000) /
			(365 + IsLeapYear((t->tm_year + TM_YEAR_BASE)))),
		(((t->tm_hour * 60) + t->tm_min)/144));
	return(strlen(s));
    }
    setlocale(LC_TIME, "");
    return strftime(s, maxsize, format, t);
}

/*
 *----------------------------------------------------------------------
 *
 * ThreadSafeGMTime --
349
350
351
352
353
354
355
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
 * Side effects:
 *	Invokes gmtime or gmtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeGMTime( timePtr )
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch
				 */

{

    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm * tmPtr = (struct tm*) Tcl_GetThreadData( &tmKey,
							sizeof( struct tm ) );
#ifdef HAVE_GMTIME_R
    gmtime_r( timePtr, tmPtr );
#else
    Tcl_MutexLock( & tmMutex );
    memcpy( (VOID *) tmPtr, (VOID *) gmtime( timePtr ), sizeof ( struct tm ) );
    Tcl_MutexUnlock( &tmMutex );
#endif    
    return tmPtr;
}

/*
 *----------------------------------------------------------------------
 *







|





<




|
|

|

|
|
|







351
352
353
354
355
356
357
358
359
360
361
362
363

364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
 * Side effects:
 *	Invokes gmtime or gmtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeGMTime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch
				 */

{

    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm *tmPtr = (struct tm *)
	    Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_GMTIME_R
    gmtime_r(timePtr, tmPtr);
#else
    Tcl_MutexLock(&tmMutex);
    memcpy((VOID *) tmPtr, (VOID *) gmtime(timePtr), sizeof(struct tm));
    Tcl_MutexUnlock(&tmMutex);
#endif    
    return tmPtr;
}

/*
 *----------------------------------------------------------------------
 *
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
 * Side effects:
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeLocalTime( timePtr )
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch
				 */

{

    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm * tmPtr = (struct tm*) Tcl_GetThreadData( &tmKey,
							sizeof( struct tm ) );
#ifdef HAVE_LOCALTIME_R
    localtime_r( timePtr, tmPtr );
#else
    Tcl_MutexLock( & tmMutex );
    memcpy( (VOID *) (tmPtr),
	    (VOID *) ( localtime( timePtr ) ),
	    sizeof (struct tm) );
    Tcl_MutexUnlock( &tmMutex );
#endif    
    return tmPtr;
}







|





<




|
|

|

|
<
|
<
|



391
392
393
394
395
396
397
398
399
400
401
402
403

404
405
406
407
408
409
410
411
412
413

414

415
416
417
418
 * Side effects:
 *	Invokes localtime or localtime_r as appropriate.
 *
 *----------------------------------------------------------------------
 */

static struct tm *
ThreadSafeLocalTime(timePtr)
    CONST time_t *timePtr;	/* Pointer to the number of seconds
				 * since the local system's epoch
				 */

{

    /*
     * Get a thread-local buffer to hold the returned time.
     */

    struct tm *tmPtr = (struct tm *)
	    Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
    localtime_r(timePtr, tmPtr);
#else
    Tcl_MutexLock(&tmMutex);

    memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm));

    Tcl_MutexUnlock(&tmMutex);
#endif    
    return tmPtr;
}
Changes to unix/tclXtTest.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
/* 
 * tclXtTest.c --
 *
 *	Contains commands for Xt notifier specific tests on Unix.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclXtTest.c,v 1.4 1999/07/02 06:05:34 welch Exp $
 */

#include <X11/Intrinsic.h>
#include "tcl.h"

static int	TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, char **argv));
extern void	InitNotifier _ANSI_ARGS_((void));


/*
 *----------------------------------------------------------------------
 *
 * Tclxttest_Init --










|






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
/* 
 * tclXtTest.c --
 *
 *	Contains commands for Xt notifier specific tests on Unix.
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclXtTest.c,v 1.4.26.1 2002/08/20 20:25:31 das Exp $
 */

#include <X11/Intrinsic.h>
#include "tcl.h"

static int	TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
		    Tcl_Interp *interp, int argc, CONST char **argv));
extern void	InitNotifier _ANSI_ARGS_((void));


/*
 *----------------------------------------------------------------------
 *
 * Tclxttest_Init --
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
 */

static int
TesteventloopCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    static int *framePtr = NULL; /* Pointer to integer on stack frame of
				  * innermost invocation of the "wait"
				  * subcommand. */

   if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],







|







71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
 */

static int
TesteventloopCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    CONST char **argv;			/* Argument strings. */
{
    static int *framePtr = NULL; /* Pointer to integer on stack frame of
				  * innermost invocation of the "wait"
				  * subcommand. */

   if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
Changes to win/Makefile.in.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.55.2.2 2002/06/10 05:33:19 wolfsuit 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







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in"
# then it is a template for a Makefile;  to generate the actual Makefile,
# run "./configure", which is a configuration script generated by the
# "autoconf" program (constructs like "@foo@" will get replaced in the
# actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.55.2.3 2002/08/20 20:25:31 das Exp $

VERSION = @TCL_VERSION@

#----------------------------------------------------------------
# Things you can change to personalize the Makefile for your own
# site (you can make these changes in either Makefile.in or
# Makefile, but changes to Makefile will get lost if you re-run
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		$(MKDIR) $$i; \
		else true; \
		fi; \
	    done;
	@for i in http1.0 http2.4 opt0.4 encoding msgcat1.2 tcltest2.0; \
	    do \
	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
		$(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \
		else true; \
		fi; \
	    done;







|







482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
	    do \
	    if [ ! -d $$i ] ; then \
		echo "Making directory $$i"; \
		$(MKDIR) $$i; \
		else true; \
		fi; \
	    done;
	@for i in http1.0 http2.4 opt0.4 encoding msgcat1.3 tcltest2.2; \
	    do \
	    if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
		echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
		$(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \
		else true; \
		fi; \
	    done;
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http2.4"; \
	    done;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing library msgcat1.2 directory";
	@for j in $(ROOT_DIR)/library/msgcat/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/msgcat1.2"; \
	    done;
	@echo "Installing library tcltest2.0 directory";
	@for j in $(ROOT_DIR)/library/tcltest/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/tcltest2.0"; \
	    done;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

install-doc: doc







|


|

|


|







516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http2.4"; \
	    done;
	@echo "Installing library opt0.4 directory";
	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
	    done;
	@echo "Installing library msgcat1.3 directory";
	@for j in $(ROOT_DIR)/library/msgcat/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/msgcat1.3"; \
	    done;
	@echo "Installing library tcltest2.2 directory";
	@for j in $(ROOT_DIR)/library/tcltest/*.tcl; \
	    do \
	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/tcltest2.2"; \
	    done;
	@echo "Installing encodings";
	@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
		$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
	done;

install-doc: doc
582
583
584
585
586
587
588

589

590
591
592
593
594
595

#
# Regenerate the stubs files.
#

$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
		$(GENERIC_DIR)/tclInt.decls

	@echo "Warning: run \"make genstubs\" to regenerate tclStubInit.c"


genstubs:
	$(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
	    "$(GENERIC_DIR_NATIVE)" \
	    "$(GENERIC_DIR_NATIVE)\tcl.decls" \
            "$(GENERIC_DIR_NATIVE)\tclInt.decls"







>
|
>






582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597

#
# Regenerate the stubs files.
#

$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
		$(GENERIC_DIR)/tclInt.decls
	@echo "Warning: tclStubInit.c may be out of date."
	@echo "Developers may want to run \"make genstubs\" to regenerate."
	@echo "This warning can be safely ignored, do not report as a bug!"

genstubs:
	$(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
	    "$(GENERIC_DIR_NATIVE)" \
	    "$(GENERIC_DIR_NATIVE)\tcl.decls" \
            "$(GENERIC_DIR_NATIVE)\tclInt.decls"
Changes to win/README.binary.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Tcl/Tk 8.4 for Windows, Binary Distribution

RCS: @(#) $Id: README.binary,v 1.26.8.1 2002/06/10 05:33:19 wolfsuit Exp $ 

1. Introduction
--------------- 

This directory contains the binary distribution of Tcl/Tk 8.4a5 for
Windows.  It was compiled with Microsoft Visual C++ 6.0 using Win32
API, so that it will run under Windows NT, 95, 98 and 2000.

Tcl provides a powerful platform for creating integration applications
that tie together diverse applications, protocols, devices, and
frameworks.  When paired with the Tk toolkit, Tcl provides the fastest
and most powerful way to create GUI applications that run on PCs, Unix,


|




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Tcl/Tk 8.4 for Windows, Binary Distribution

RCS: @(#) $Id: README.binary,v 1.26.8.2 2002/08/20 20:25:31 das Exp $ 

1. Introduction
--------------- 

This directory contains the binary distribution of Tcl/Tk 8.4b3 for
Windows.  It was compiled with Microsoft Visual C++ 6.0 using Win32
API, so that it will run under Windows NT, 95, 98 and 2000.

Tcl provides a powerful platform for creating integration applications
that tie together diverse applications, protocols, devices, and
frameworks.  When paired with the Tk toolkit, Tcl provides the fastest
and most powerful way to create GUI applications that run on PCs, Unix,
Changes to win/configure.
525
526
527
528
529
530
531

532
533
534
535
536
537
538
539
540
541
542
543
    ac_n=-n ac_c= ac_t=
  fi
else
  ac_n= ac_c='\c' ac_t=
fi




TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="a5"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION







>




|







525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
    ac_n=-n ac_c= ac_t=
  fi
else
  ac_n= ac_c='\c' ac_t=
fi




TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="b3"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
if test "${CFLAGS+set}" != "set" ; then
    CFLAGS=""
fi

# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:578: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
if test "${CFLAGS+set}" != "set" ; then
    CFLAGS=""
fi

# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:579: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
  echo "$ac_t""no" 1>&6
fi

if test -z "$CC"; then
  # Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:608: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
  echo "$ac_t""no" 1>&6
fi

if test -z "$CC"; then
  # Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:609: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665

  if test -z "$CC"; then
    case "`uname -s`" in
    *win32* | *WIN32*)
      # Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:659: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







652
653
654
655
656
657
658
659
660
661
662
663
664
665
666

  if test -z "$CC"; then
    case "`uname -s`" in
    *win32* | *WIN32*)
      # Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:660: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CC"; then
  ac_cv_prog_CC="$CC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
 ;;
    esac
  fi
  test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi

echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
echo "configure:691: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5

ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross

cat > conftest.$ac_ext << EOF

#line 702 "configure"
#include "confdefs.h"

main(){return(0);}
EOF
if { (eval echo configure:707: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  ac_cv_prog_cc_works=yes
  # If we can't run a trivial program, we are probably using a cross compiler.
  if (./conftest; exit) 2>/dev/null; then
    ac_cv_prog_cc_cross=no
  else
    ac_cv_prog_cc_cross=yes
  fi







|










|




|







684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
 ;;
    esac
  fi
  test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi

echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
echo "configure:692: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5

ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross

cat > conftest.$ac_ext << EOF

#line 703 "configure"
#include "confdefs.h"

main(){return(0);}
EOF
if { (eval echo configure:708: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
  ac_cv_prog_cc_works=yes
  # If we can't run a trivial program, we are probably using a cross compiler.
  if (./conftest; exit) 2>/dev/null; then
    ac_cv_prog_cc_cross=no
  else
    ac_cv_prog_cc_cross=yes
  fi
725
726
727
728
729
730
731
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
cross_compiling=$ac_cv_prog_cc_cross

echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
if test $ac_cv_prog_cc_works = no; then
  { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
echo "configure:733: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross

echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
echo "configure:738: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.c <<EOF
#ifdef __GNUC__
  yes;
#endif
EOF
if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:747: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
  ac_cv_prog_gcc=yes
else
  ac_cv_prog_gcc=no
fi
fi

echo "$ac_t""$ac_cv_prog_gcc" 1>&6

if test $ac_cv_prog_gcc = yes; then
  GCC=yes
else
  GCC=
fi

ac_test_CFLAGS="${CFLAGS+set}"
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
echo "configure:766: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
  ac_cv_prog_cc_g=yes
else







|




|








|


















|







726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
cross_compiling=$ac_cv_prog_cc_cross

echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
if test $ac_cv_prog_cc_works = no; then
  { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
echo "configure:734: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross

echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
echo "configure:739: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.c <<EOF
#ifdef __GNUC__
  yes;
#endif
EOF
if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:748: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
  ac_cv_prog_gcc=yes
else
  ac_cv_prog_gcc=no
fi
fi

echo "$ac_t""$ac_cv_prog_gcc" 1>&6

if test $ac_cv_prog_gcc = yes; then
  GCC=yes
else
  GCC=
fi

ac_test_CFLAGS="${CFLAGS+set}"
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
echo "configure:767: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
  ac_cv_prog_cc_g=yes
else
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
# the CC, AR, RANLIB, and RC environment
# variables if you want to cross compile.

if test "${GCC}" = "yes" ; then
    # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:809: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$AR"; then
  ac_cv_prog_AR="$AR" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
# the CC, AR, RANLIB, and RC environment
# variables if you want to cross compile.

if test "${GCC}" = "yes" ; then
    # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:810: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$AR"; then
  ac_cv_prog_AR="$AR" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
else
  echo "$ac_t""no" 1>&6
fi

    # Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:838: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$RANLIB"; then
  ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
else
  echo "$ac_t""no" 1>&6
fi

    # Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:839: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$RANLIB"; then
  ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
else
  echo "$ac_t""no" 1>&6
fi

    # Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:867: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$RC"; then
  ac_cv_prog_RC="$RC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|







860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
else
  echo "$ac_t""no" 1>&6
fi

    # Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:868: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RC'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$RC"; then
  ac_cv_prog_RC="$RC" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
fi

#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------

echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
echo "configure:900: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftestmake <<\EOF
all:
	@echo 'ac_maketemp="${MAKE}"'







|







893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
fi

#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------

echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
echo "configure:901: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftestmake <<\EOF
all:
	@echo 'ac_maketemp="${MAKE}"'
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954


#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------

echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
echo "configure:932: checking for Cygwin environment" >&5
if eval "test \"`echo '$''{'ac_cv_cygwin'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 937 "configure"
#include "confdefs.h"

int main() {

#ifndef __CYGWIN__
#define __CYGWIN__ __CYGWIN32__
#endif
return __CYGWIN__;
; return 0; }
EOF
if { (eval echo configure:948: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_cygwin=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_cygwin=no







|




|










|







925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955


#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------

echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
echo "configure:933: checking for Cygwin environment" >&5
if eval "test \"`echo '$''{'ac_cv_cygwin'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 938 "configure"
#include "confdefs.h"

int main() {

#ifndef __CYGWIN__
#define __CYGWIN__ __CYGWIN32__
#endif
return __CYGWIN__;
; return 0; }
EOF
if { (eval echo configure:949: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_cygwin=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_cygwin=no
964
965
966
967
968
969
970
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
if test "$ac_cv_cygwin" = "yes" ; then
    { echo "configure: error: Compiling with the Cygwin version of gcc is not supported.
    Use the Mingw version of gcc from www.mingw.org instead." 1>&2; exit 1; }
fi


echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
echo "configure:972: checking for SEH support in compiler" >&5
if eval "test \"`echo '$''{'tcl_cv_seh'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_seh=no
else
  cat > conftest.$ac_ext <<EOF
#line 980 "configure"
#include "confdefs.h"

#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN

int main(int argc, char** argv) {
    int a, b = 0;
    __try {
        a = 666 / b;
    }
    __except (EXCEPTION_EXECUTE_HANDLER) {
        return 0;
    }
    return 1;
}

EOF
if { (eval echo configure:999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_seh=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_seh=no







|







|


















|







965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
if test "$ac_cv_cygwin" = "yes" ; then
    { echo "configure: error: Compiling with the Cygwin version of gcc is not supported.
    Use the Mingw version of gcc from www.mingw.org instead." 1>&2; exit 1; }
fi


echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
echo "configure:973: checking for SEH support in compiler" >&5
if eval "test \"`echo '$''{'tcl_cv_seh'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$cross_compiling" = yes; then
  tcl_cv_seh=no
else
  cat > conftest.$ac_ext <<EOF
#line 981 "configure"
#include "confdefs.h"

#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN

int main(int argc, char** argv) {
    int a, b = 0;
    __try {
        a = 666 / b;
    }
    __except (EXCEPTION_EXECUTE_HANDLER) {
        return 0;
    }
    return 1;
}

EOF
if { (eval echo configure:1000: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
  tcl_cv_seh=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -fr conftest*
  tcl_cv_seh=no
1019
1020
1021
1022
1023
1024
1025
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
fi

#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------

echo $ac_n "checking for object suffix""... $ac_c" 1>&6
echo "configure:1027: checking for object suffix" >&5
if eval "test \"`echo '$''{'ac_cv_objext'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  rm -f conftest*
echo 'int i = 1;' > conftest.$ac_ext
if { (eval echo configure:1033: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  for ac_file in conftest.*; do
    case $ac_file in
    *.c) ;;
    *) ac_cv_objext=`echo $ac_file | sed -e s/conftest.//` ;;
    esac
  done
else
  { echo "configure: error: installation or configuration problem; compiler does not work" 1>&2; exit 1; }
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_objext" 1>&6
OBJEXT=$ac_cv_objext
ac_objext=$ac_cv_objext

echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6
echo "configure:1051: checking for mingw32 environment" >&5
if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1056 "configure"
#include "confdefs.h"

int main() {
return __MINGW32__;
; return 0; }
EOF
if { (eval echo configure:1063: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_mingw32=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_mingw32=no
fi
rm -f conftest*
rm -f conftest*
fi

echo "$ac_t""$ac_cv_mingw32" 1>&6
MINGW32=
test "$ac_cv_mingw32" = yes && MINGW32=yes


echo $ac_n "checking for executable suffix""... $ac_c" 1>&6
echo "configure:1082: checking for executable suffix" >&5
if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$CYGWIN" = yes || test "$MINGW32" = yes; then
  ac_cv_exeext=.exe
else
  rm -f conftest*
  echo 'int main () { return 0; }' > conftest.$ac_ext
  ac_cv_exeext=
  if { (eval echo configure:1092: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
    for file in conftest.*; do
      case $file in
      *.c | *.o | *.obj) ;;
      *) ac_cv_exeext=`echo $file | sed -e s/conftest//` ;;
      esac
    done
  else







|





|

















|




|






|


















|









|







1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
fi

#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------

echo $ac_n "checking for object suffix""... $ac_c" 1>&6
echo "configure:1028: checking for object suffix" >&5
if eval "test \"`echo '$''{'ac_cv_objext'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  rm -f conftest*
echo 'int i = 1;' > conftest.$ac_ext
if { (eval echo configure:1034: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  for ac_file in conftest.*; do
    case $ac_file in
    *.c) ;;
    *) ac_cv_objext=`echo $ac_file | sed -e s/conftest.//` ;;
    esac
  done
else
  { echo "configure: error: installation or configuration problem; compiler does not work" 1>&2; exit 1; }
fi
rm -f conftest*
fi

echo "$ac_t""$ac_cv_objext" 1>&6
OBJEXT=$ac_cv_objext
ac_objext=$ac_cv_objext

echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6
echo "configure:1052: checking for mingw32 environment" >&5
if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1057 "configure"
#include "confdefs.h"

int main() {
return __MINGW32__;
; return 0; }
EOF
if { (eval echo configure:1064: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
  rm -rf conftest*
  ac_cv_mingw32=yes
else
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  ac_cv_mingw32=no
fi
rm -f conftest*
rm -f conftest*
fi

echo "$ac_t""$ac_cv_mingw32" 1>&6
MINGW32=
test "$ac_cv_mingw32" = yes && MINGW32=yes


echo $ac_n "checking for executable suffix""... $ac_c" 1>&6
echo "configure:1083: checking for executable suffix" >&5
if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test "$CYGWIN" = yes || test "$MINGW32" = yes; then
  ac_cv_exeext=.exe
else
  rm -f conftest*
  echo 'int main () { return 0; }' > conftest.$ac_ext
  ac_cv_exeext=
  if { (eval echo configure:1093: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
    for file in conftest.*; do
      case $file in
      *.c | *.o | *.obj) ;;
      *) ac_cv_exeext=`echo $file | sed -e s/conftest//` ;;
      esac
    done
  else
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125

#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
#--------------------------------------------------------------------


    echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:1119: checking for building with threads" >&5
    # Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
  enableval="$enable_threads"
  tcl_ok=$enableval
else
  tcl_ok=no
fi







|







1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126

#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
#--------------------------------------------------------------------


    echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:1120: checking for building with threads" >&5
    # Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
  enableval="$enable_threads"
  tcl_ok=$enableval
else
  tcl_ok=no
fi
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------


    echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:1150: checking how to build libraries" >&5
    # Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
  enableval="$enable_shared"
  tcl_ok=$enableval
else
  tcl_ok=yes
fi







|







1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------


    echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:1151: checking how to build libraries" >&5
    # Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
  enableval="$enable_shared"
  tcl_ok=$enableval
else
  tcl_ok=yes
fi
1183
1184
1185
1186
1187
1188
1189
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
#--------------------------------------------------------------------



    # Step 0: Enable 64 bit support?

    echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:1191: checking if 64bit support is requested" >&5
    # Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
  enableval="$enable_64bit"
  do64bit=$enableval
else
  do64bit=no
fi

    echo "$ac_t""$do64bit" 1>&6

    # Set some defaults (may get changed below)
    EXTRA_CFLAGS=""

    # Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:1208: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CYGPATH'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CYGPATH"; then
  ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"







|
















|







1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
#--------------------------------------------------------------------



    # Step 0: Enable 64 bit support?

    echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:1192: checking if 64bit support is requested" >&5
    # Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
  enableval="$enable_64bit"
  do64bit=$enableval
else
  do64bit=no
fi

    echo "$ac_t""$do64bit" 1>&6

    # Set some defaults (may get changed below)
    EXTRA_CFLAGS=""

    # Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:1209: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CYGPATH'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  if test -n "$CYGPATH"; then
  ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test.
else
  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS=":"
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
    else
        DEPARG='"$(shell $(CYGPATH) $<)"'
    fi

    # set various compiler flags depending on whether we are using gcc or cl

    echo $ac_n "checking compiler flags""... $ac_c" 1>&6
echo "configure:1245: checking compiler flags" >&5
    if test "${GCC}" = "yes" ; then
	if test "$do64bit" = "yes" ; then
	    echo "configure: warning: "64bit mode not supported with GCC on Windows"" 1>&2
	fi
	SHLIB_LD=""
	SHLIB_LD_LIBS=""
	LIBS=""







|







1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
    else
        DEPARG='"$(shell $(CYGPATH) $<)"'
    fi

    # set various compiler flags depending on whether we are using gcc or cl

    echo $ac_n "checking compiler flags""... $ac_c" 1>&6
echo "configure:1246: checking compiler flags" >&5
    if test "${GCC}" = "yes" ; then
	if test "$do64bit" = "yes" ; then
	    echo "configure: warning: "64bit mode not supported with GCC on Windows"" 1>&2
	fi
	SHLIB_LD=""
	SHLIB_LD_LIBS=""
	LIBS=""
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
# Set the default compiler switches based on the --enable-symbols 
# option.  This macro depends on C flags, and should be called
# after SC_CONFIG_CFLAGS macro is called.
#--------------------------------------------------------------------


    echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:1435: checking for build with symbols" >&5
    # Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
  enableval="$enable_symbols"
  tcl_ok=$enableval
else
  tcl_ok=no
fi







|







1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
# Set the default compiler switches based on the --enable-symbols 
# option.  This macro depends on C flags, and should be called
# after SC_CONFIG_CFLAGS macro is called.
#--------------------------------------------------------------------


    echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:1436: checking for build with symbols" >&5
    # Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
  enableval="$enable_symbols"
  tcl_ok=$enableval
else
  tcl_ok=no
fi
1457
1458
1459
1460
1461
1462
1463
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
TCL_DBGX=${DBGX}

#--------------------------------------------------------------------
# man2tcl needs this so that it can use errno.h
#--------------------------------------------------------------------

echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:1465: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
  CPP=
fi
if test -z "$CPP"; then
if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
    # This must be in double quotes, not single quotes, because CPP may get
  # substituted into the Makefile and "${CC-cc}" will confuse make.
  CPP="${CC-cc} -E"
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp.
  cat > conftest.$ac_ext <<EOF
#line 1480 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1486: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -E -traditional-cpp"
  cat > conftest.$ac_ext <<EOF
#line 1497 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1503: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -nologo -E"
  cat > conftest.$ac_ext <<EOF
#line 1514 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1520: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5







|














|





|










|





|










|





|







1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
TCL_DBGX=${DBGX}

#--------------------------------------------------------------------
# man2tcl needs this so that it can use errno.h
#--------------------------------------------------------------------

echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:1466: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
  CPP=
fi
if test -z "$CPP"; then
if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
    # This must be in double quotes, not single quotes, because CPP may get
  # substituted into the Makefile and "${CC-cc}" will confuse make.
  CPP="${CC-cc} -E"
  # On the NeXT, cc -E runs the code through the compiler's parser,
  # not just through cpp.
  cat > conftest.$ac_ext <<EOF
#line 1481 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1487: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -E -traditional-cpp"
  cat > conftest.$ac_ext <<EOF
#line 1498 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1504: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
  rm -rf conftest*
  CPP="${CC-cc} -nologo -E"
  cat > conftest.$ac_ext <<EOF
#line 1515 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1521: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  :
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
  cat conftest.$ac_ext >&5
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
else
  ac_cv_prog_CPP="$CPP"
fi
echo "$ac_t""$CPP" 1>&6

ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:1546: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1551 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1556: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5







|




|




|







1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
else
  ac_cv_prog_CPP="$CPP"
fi
echo "$ac_t""$CPP" 1>&6

ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:1547: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  cat > conftest.$ac_ext <<EOF
#line 1552 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1557: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
  rm -rf conftest*
  eval "ac_cv_header_$ac_safe=yes"
else
  echo "$ac_err" >&5
  echo "configure: failed program was:" >&5
Changes to win/configure.in.
1
2
3
4
5
6
7
8

9
10
11
12
13
14
15
16
17
18
19
20
#! /bin/bash -norc
# This file is an input file used by the GNU "autoconf" program to
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.41.4.2 2002/06/10 05:33:19 wolfsuit Exp $

AC_INIT(../generic/tcl.h)


TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="a5"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION





|


>




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
#! /bin/bash -norc
# This file is an input file used by the GNU "autoconf" program to
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.41.4.3 2002/08/20 20:25:31 das Exp $

AC_INIT(../generic/tcl.h)
AC_PREREQ(2.13)

TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="b3"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION

TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
Changes to win/makefile.bc.
398
399
400
401
402
403
404
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
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
	@echo installing http1.0
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
	-@copy "$(ROOT)\library\http1.0\http.tcl"     "$(SCRIPT_INSTALL_DIR)\http1.0"
	-@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
	@echo installing http2.4
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.4"
	-@copy "$(ROOT)\library\http2.4\http.tcl"     "$(SCRIPT_INSTALL_DIR)\http2.4"
	-@copy "$(ROOT)\library\http2.4\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.4"
	@echo installing opt0.4
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
	-@copy "$(ROOT)\library\opt0.4\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
	-@copy "$(ROOT)\library\opt0.4\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
	@echo installing msgcat1.0
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
	-@copy "$(ROOT)\library\msgcat1.0\msgcat.tcl"   "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
	-@copy "$(ROOT)\library\msgcat1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0"




	@echo installing $(TCLDDEDLLNAME)
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1"
	-@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1"
	-@copy "$(ROOT)\library\dde1.1\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1"
	@echo installing $(TCLREGDLLNAME)
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.0"
	-@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.0"
	-@copy "$(ROOT)\library\reg1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.0"
	@echo installing encoding files
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
	-@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
	@echo installing library files
	-@copy "$(GENERICDIR)\tcl.h"         "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclDecls.h"    "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"







|
|


|
|
|
|
|
|
>
>
>
>



|



|







398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
	@echo installing http1.0
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
	-@copy "$(ROOT)\library\http1.0\http.tcl"     "$(SCRIPT_INSTALL_DIR)\http1.0"
	-@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
	@echo installing http2.4
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.4"
	-@copy "$(ROOT)\library\http\http.tcl"     "$(SCRIPT_INSTALL_DIR)\http2.4"
	-@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.4"
	@echo installing opt0.4
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
	-@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
	-@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
	@echo installing msgcat1.3
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.3"
	-@copy "$(ROOT)\library\msgcat\msgcat.tcl"   "$(SCRIPT_INSTALL_DIR)\msgcat1.3"
	-@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.3"
	@echo installing tcltest2.2
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.2"
	-@copy "$(ROOT)\library\tcltest\tcltest.tcl"   "$(SCRIPT_INSTALL_DIR)\tcltest2.2"
	-@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.2"
	@echo installing $(TCLDDEDLLNAME)
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1"
	-@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1"
	-@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1"
	@echo installing $(TCLREGDLLNAME)
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.0"
	-@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.0"
	-@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.0"
	@echo installing encoding files
	-@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
	-@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
	@echo installing library files
	-@copy "$(GENERICDIR)\tcl.h"         "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclDecls.h"    "$(INCLUDE_INSTALL_DIR)"
	-@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"
Changes to win/makefile.vc.
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
# Copyright (c) 2001 ActiveState Corporation.
# Copyright (c) 2001-2002 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: makefile.vc,v 1.66.2.1 2002/06/10 05:33:19 wolfsuit Exp $
#------------------------------------------------------------------------------

!if "$(MSVCDIR)" == ""
MSG = ^
You'll need to run vcvars32.bat from Developer Studio, first, to setup^
the environment.  Jump to this line to read the new instructions.
!error $(MSG)







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
# Copyright (c) 2001 ActiveState Corporation.
# Copyright (c) 2001-2002 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: makefile.vc,v 1.66.2.2 2002/08/20 20:25:31 das Exp $
#------------------------------------------------------------------------------

!if "$(MSVCDIR)" == ""
MSG = ^
You'll need to run vcvars32.bat from Developer Studio, first, to setup^
the environment.  Jump to this line to read the new instructions.
!error $(MSG)
727
728
729
730
731
732
733
734
735
736



737
738
739
740
741
742
743
		"$(SCRIPT_INSTALL_DIR)\http1.0\"
	@echo installing http2.4
	@xcopy /i /y "$(ROOT)\library\http\*.tcl" \
		"$(SCRIPT_INSTALL_DIR)\http2.4\"
	@echo installing opt0.4
	@xcopy /i /y "$(ROOT)\library\opt\*.tcl" \
		"$(SCRIPT_INSTALL_DIR)\opt0.4\"
	@echo installing msgcat1.2
	@xcopy /i /y "$(ROOT)\library\msgcat\*.tcl" \
	    "$(SCRIPT_INSTALL_DIR)\msgcat1.2\"



	@echo installing $(TCLDDELIBNAME)
!if $(STATIC_BUILD)
	@xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\"
!else
	@xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
	@xcopy /i /y "$(ROOT)\library\dde\pkgIndex.tcl" \
	    "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"







|

|
>
>
>







727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
		"$(SCRIPT_INSTALL_DIR)\http1.0\"
	@echo installing http2.4
	@xcopy /i /y "$(ROOT)\library\http\*.tcl" \
		"$(SCRIPT_INSTALL_DIR)\http2.4\"
	@echo installing opt0.4
	@xcopy /i /y "$(ROOT)\library\opt\*.tcl" \
		"$(SCRIPT_INSTALL_DIR)\opt0.4\"
	@echo installing msgcat1.3
	@xcopy /i /y "$(ROOT)\library\msgcat\*.tcl" \
	    "$(SCRIPT_INSTALL_DIR)\msgcat1.3\"
	@echo installing tcltest2.2 
	@xcopy /i /y "$(ROOT)\library\tcltest\*.tcl" \
	    "$(SCRIPT_INSTALL_DIR)\tcltest2.2\"
	@echo installing $(TCLDDELIBNAME)
!if $(STATIC_BUILD)
	@xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\"
!else
	@xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
	@xcopy /i /y "$(ROOT)\library\dde\pkgIndex.tcl" \
	    "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
Changes to win/rules.vc.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#------------------------------------------------------------------------------
# rules.vc --
#
#	Microsoft Visual C++ makefile include for decoding the commandline
#	macros.  This file does not need editing to build Tcl.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2001-2002 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: rules.vc,v 1.4.4.2 2002/06/10 05:33:19 wolfsuit Exp $
#------------------------------------------------------------------------------

!ifndef _RULES_VC
_RULES_VC = 1

cc32		= $(CC)   # built-in default.
link32		= link












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
#------------------------------------------------------------------------------
# rules.vc --
#
#	Microsoft Visual C++ makefile include for decoding the commandline
#	macros.  This file does not need editing to build Tcl.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2001-2002 David Gravereaux.
#
#------------------------------------------------------------------------------
# RCS: @(#) $Id: rules.vc,v 1.4.4.3 2002/08/20 20:25:31 das Exp $
#------------------------------------------------------------------------------

!ifndef _RULES_VC
_RULES_VC = 1

cc32		= $(CC)   # built-in default.
link32		= link
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
!endif

#----------------------------------------------------------
# Test for compiler features
#----------------------------------------------------------

### test for optimizations
!if [nmakehlp -c -Ox]
!message *** Compiler has 'Optimizations'
OPTIMIZING	= 1
!else
!message *** Compiler doesn't have 'Optimizations'
OPTIMIZING	= 0
!endif








|







42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
!endif

#----------------------------------------------------------
# Test for compiler features
#----------------------------------------------------------

### test for optimizations
!if [nmakehlp -c -Otip ]
!message *** Compiler has 'Optimizations'
OPTIMIZING	= 1
!else
!message *** Compiler doesn't have 'Optimizations'
OPTIMIZING	= 0
!endif

Changes to win/tcl.rc.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
// RCS: @(#) $Id: tcl.rc,v 1.7 2001/10/01 20:57:20 hobbs Exp $
//
// Version Resource Script
//

#include <winver.h>

#define RESOURCE_INCLUDED
#include <tcl.h>

//
// build-up the name suffix that defines the type of build this is.
//
#ifdef TCL_THREADS
#define SUFFIX_THREADS	    "t"
|





<
<







1
2
3
4
5
6


7
8
9
10
11
12
13
// RCS: @(#) $Id: tcl.rc,v 1.7.2.1 2002/08/20 20:25:31 das Exp $
//
// Version Resource Script
//

#include <winver.h>


#include <tcl.h>

//
// build-up the name suffix that defines the type of build this is.
//
#ifdef TCL_THREADS
#define SUFFIX_THREADS	    "t"
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
        BEGIN
            VALUE "FileDescription", "Tcl DLL\0"
            VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0"
            VALUE "CompanyName", "ActiveState Corporation\0"
            VALUE "FileVersion", TCL_PATCH_LEVEL
            VALUE "LegalCopyright", "Copyright \251 2001 by ActiveState Corporation, et al\0"
            VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
            VALUE "ProductVersion", TCL_PATCH_LEVEL
        END		    
    END
    BLOCK "VarFileInfo"
    BEGIN
        VALUE "Translation", 0x409, 1200
    END
END







|












40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
        BEGIN
            VALUE "FileDescription", "Tcl DLL\0"
            VALUE "OriginalFilename", "tcl" STRINGIFY(JOIN(TCL_MAJOR_VERSION,TCL_MINOR_VERSION)) SUFFIX ".dll\0"
            VALUE "CompanyName", "ActiveState Corporation\0"
            VALUE "FileVersion", TCL_PATCH_LEVEL
            VALUE "LegalCopyright", "Copyright \251 2001 by ActiveState Corporation, et al\0"
            VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
            VALUE "ProductVersion", TCL_PATCH_LEVEL
        END		    
    END
    BLOCK "VarFileInfo"
    BEGIN
        VALUE "Translation", 0x409, 1200
    END
END
Changes to win/tclWin32Dll.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWin32Dll.c --
 *
 *	This file contains the DLL entry point.
 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWin32Dll.c,v 1.9.18.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#include "tclWinInt.h"

/*
 * The following data structures are used when loading the thunking 
 * library for execing child processes under Win32s.











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWin32Dll.c --
 *
 *	This file contains the DLL entry point.
 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWin32Dll.c,v 1.9.18.3 2002/08/20 20:25:31 das Exp $
 */

#include "tclWinInt.h"

/*
 * The following data structures are used when loading the thunking 
 * library for execing child processes under Win32s.
80
81
82
83
84
85
86

87
88
89
90
91
92
93
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathA,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
    NULL,

};

static TclWinProcs unicodeProcs = {
    1,

    (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
    (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,







>







80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathA,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
    NULL,
    NULL,
};

static TclWinProcs unicodeProcs = {
    1,

    (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
    (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
117
118
119
120
121
122
123

124
125
126
127
128
129
130
    (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathW,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,

    NULL,
};

TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;

/*







>







118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
    (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
    (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
    (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
    (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, 
	    WCHAR *, TCHAR **)) SearchPathW,
    (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
    (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
    NULL,
    NULL,
};

TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;

/*
463
464
465
466
467
468
469




470
471
472
473
474
475
476
477
478
479
480
481




482
483
484
485
486
487
488
	tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
	        tclWinProcs->getFileAttributesExProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, 
		  LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");




		FreeLibrary(hInstance);
	    }
	}
    } else {
	tclWinProcs = &asciiProcs;
	tclWinTCharEncoding = NULL;
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileAttributesExProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, 
		  LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");




		FreeLibrary(hInstance);
	    }
	}
    }
}

/*







>
>
>
>












>
>
>
>







465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
	tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
	        tclWinProcs->getFileAttributesExProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, 
		  LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
		tclWinProcs->createHardLinkProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, 
		  LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, 
		  "CreateHardLinkW");
		FreeLibrary(hInstance);
	    }
	}
    } else {
	tclWinProcs = &asciiProcs;
	tclWinTCharEncoding = NULL;
	if (tclWinProcs->getFileAttributesExProc == NULL) {
	    HINSTANCE hInstance = LoadLibraryA("kernel32");
	    if (hInstance != NULL) {
		tclWinProcs->getFileAttributesExProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, 
		  LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");
		tclWinProcs->createHardLinkProc = 
		  (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, 
		  LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, 
		  "CreateHardLinkA");
		FreeLibrary(hInstance);
	    }
	}
    }
}

/*
Changes to win/tclWinChan.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWinChan.c
 *
 *	Channel drivers for Windows channels based on files, command
 *	pipes and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinChan.c,v 1.15.8.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#include "tclWinInt.h"

/*
 * State flags used in the info structures below.
 */











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWinChan.c
 *
 *	Channel drivers for Windows channels based on files, command
 *	pipes and TCP sockets.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinChan.c,v 1.15.8.3 2002/08/20 20:25:31 das Exp $
 */

#include "tclWinInt.h"

/*
 * State flags used in the info structures below.
 */
740
741
742
743
744
745
746
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
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(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_Channel channel = 0;
    int seekFlag, mode, channelPermissions;
    DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
    CONST TCHAR *nativeName;
    DCB dcb;
    HANDLE handle;
    char channelName[16 + TCL_INTEGER_SPACE];
    TclFile readFile = NULL;
    TclFile writeFile = NULL;

    mode = TclGetOpenMode(interp, modeString, &seekFlag);
    if (mode == -1) {
        return NULL;
    }

    nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
    if (nativeName == NULL) {
	return NULL;
    }
    
    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:







|



|
<





|








<
<
<
<
<







740
741
742
743
744
745
746
747
748
749
750
751

752
753
754
755
756
757
758
759
760
761
762
763
764
765





766
767
768
769
770
771
772
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */

Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
    Tcl_Interp *interp;			/* Interpreter for error reporting;
                                         * can be NULL. */
    Tcl_Obj *pathPtr;			/* Name of file to open. */
    int mode;				/* POSIX mode. */

    int permissions;			/* If the open involves creating a
                                         * file, with what modes to create
                                         * it? */
{
    Tcl_Channel channel = 0;
    int channelPermissions;
    DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
    CONST TCHAR *nativeName;
    DCB dcb;
    HANDLE handle;
    char channelName[16 + TCL_INTEGER_SPACE];
    TclFile readFile = NULL;
    TclFile writeFile = NULL;






    nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
    if (nativeName == NULL) {
	return NULL;
    }
    
    switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
	case O_RDONLY:
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
	channel = NULL;
	Tcl_AppendResult(interp, "couldn't open \"", 
			 Tcl_GetString(pathPtr), "\": ",
			 "bad file type", (char *) NULL);
	break;
    }

    if (channel != NULL) {
	if (seekFlag) {
	    if (Tcl_Seek(channel, 0, SEEK_END) < 0) {
		if (interp != (Tcl_Interp *) NULL) {
		    Tcl_AppendResult(interp,
			    "could not seek to end of file on \"",
			    channelName, "\": ", Tcl_PosixError(interp),
			    (char *) NULL);
		}
		Tcl_Close(NULL, channel);
		return NULL;
	    }
	}
    }
    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeFileChannel --







<
<
<
<
<
<
<
<
<
<
<
<
<
<







927
928
929
930
931
932
933














934
935
936
937
938
939
940
	channel = NULL;
	Tcl_AppendResult(interp, "couldn't open \"", 
			 Tcl_GetString(pathPtr), "\": ",
			 "bad file type", (char *) NULL);
	break;
    }















    return channel;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_MakeFileChannel --
Changes to win/tclWinFCmd.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclWinFCmd.c
 *
 *      This file implements the Windows specific portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFCmd.c,v 1.14.2.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#include "tclWinInt.h"

/*
 * The following constants specify the type of callback when
 * TraverseWinTree() calls the traverseProc()











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/*
 * tclWinFCmd.c
 *
 *      This file implements the Windows specific portion of file manipulation 
 *      subcommands of the "file" command. 
 *
 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFCmd.c,v 1.14.2.3 2002/08/20 20:25:31 das Exp $
 */

#include "tclWinInt.h"

/*
 * The following constants specify the type of callback when
 * TraverseWinTree() calls the traverseProc()
562
563
564
565
566
567
568






569
570
571
572
573
574
575
	dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
	if (srcAttr != 0xffffffff) {
	    if (dstAttr == 0xffffffff) {
		dstAttr = 0;
	    }
	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {






		Tcl_SetErrno(EISDIR);
	    }
	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
		(*tclWinProcs->setFileAttributesProc)(nativeDst, 
			dstAttr & ~FILE_ATTRIBUTE_READONLY);
		if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
		    return TCL_OK;







>
>
>
>
>
>







562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
	dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
	if (srcAttr != 0xffffffff) {
	    if (dstAttr == 0xffffffff) {
		dstAttr = 0;
	    }
	    if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
		    (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
		if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /* Source is a symbolic link -- copy it */
		    if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
		        return TCL_OK;
		    }
		}
		Tcl_SetErrno(EISDIR);
	    }
	    if (dstAttr & FILE_ATTRIBUTE_READONLY) {
		(*tclWinProcs->setFileAttributesProc)(nativeDst, 
			dstAttr & ~FILE_ATTRIBUTE_READONLY);
		if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
		    return TCL_OK;
655
656
657
658
659
660
661







662


663
664
665
666
667
668
669
    }
    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_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, 







>
>
>
>
>
>
>
|
>
>







661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
    }
    TclWinConvertError(GetLastError());

    if (Tcl_GetErrno() == EACCES) {
        attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
	if (attr != 0xffffffff) {
	    if (attr & FILE_ATTRIBUTE_DIRECTORY) {
		if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
		    /* It is a symbolic link -- remove it */
		    if (TclWinSymLinkDelete(nativePath, 0) == 0) {
		        return TCL_OK;
		    }
		}
		
		/* 
		 * If we fall through here, it is a directory.
		 * 
		 * Windows NT reports removing a directory as EACCES instead
		 * of EISDIR.
		 */

		Tcl_SetErrno(EISDIR);
	    } else if (attr & FILE_ATTRIBUTE_READONLY) {
		int res = (*tclWinProcs->setFileAttributesProc)(nativePath, 
899
900
901
902
903
904
905







906
907
908
909
910
911
912
		 * EACCES, not an ENOTDIR.
		 */
		
		Tcl_SetErrno(ENOTDIR);
		goto end;
	    }








	    if (attr & FILE_ATTRIBUTE_READONLY) {
		attr &= ~FILE_ATTRIBUTE_READONLY;
		if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
		    goto end;
		}
		if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
		    return TCL_OK;







>
>
>
>
>
>
>







914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
		 * EACCES, not an ENOTDIR.
		 */
		
		Tcl_SetErrno(ENOTDIR);
		goto end;
	    }

	    if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
		/* It is a symbolic link -- remove it */
		if (TclWinSymLinkDelete(nativePath, 1) != 0) {
		    goto end;
		}
	    }
	    
	    if (attr & FILE_ATTRIBUTE_READONLY) {
		attr &= ~FILE_ATTRIBUTE_READONLY;
		if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
		    goto end;
		}
		if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
		    return TCL_OK;
1808
1809
1810
1811
1812
1813
1814
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
	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }
    
    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}

/* 
 * This function could be thoroughly tested and then substituted in
 * below to speed up file normalization on Windows NT/2000/XP
 */
#if 0

void WinGetLongPathName(CONST TCHAR* origPath, Tcl_DString *dsPtr);

#define IsDirSep(a) (a == '/' || a == '\\')

void WinGetLongPathName(CONST TCHAR* pszOriginal, Tcl_DString *dsPtr) {
    TCHAR szResult[_MAX_PATH * 2 + 1];		
    
    TCHAR* pchResult = szResult;
    const TCHAR* pchScan = pszOriginal;
    WIN32_FIND_DATA wfd;
    
    /* Do Drive Letter check... */
    if (pchScan[0] && pchScan[1] == ':') {
	/* Copy drive letter and colon, ensuring drive is upper case. */
	char drive = *pchScan++;
	*pchResult++ = (drive < 97 ? drive : drive - 32);
	*pchResult++ = *pchScan++;
    } else if (IsDirSep(pchScan[0]) && IsDirSep(pchScan[1])) {
	/* Copy \\ and machine name. */
	*pchResult++ = *pchScan++;
	*pchResult++ = *pchScan++;
	while (*pchScan && !IsDirSep(*pchScan)) {
	    *pchResult++ = *pchScan++;
	}
	/* 
	 * Note that the code below will fail since FindFirstFile
	 * on a UNC path seems not to work on directory name searches?
	 */
    }
  
    if (!IsDirSep(*pchScan)) {
	while ((*pchResult++ = *pchScan++) != '\0');
    } else {
	/* Now loop through directories and files... */
	while (IsDirSep(*pchScan)) {
	    char* pchReplace;
	    const TCHAR* pchEnd;
	    HANDLE hFind;
	    
	    *pchResult++ = *pchScan++;
	    pchReplace = pchResult;
	    
	    pchEnd = pchScan;
	    while (*pchEnd && !IsDirSep(*pchEnd)) {
		*pchResult++ = *pchEnd++;
	    }
	    
	    *pchResult = '\0';
	    
	    /* Now run this through FindFirstFile... */
	    hFind = FindFirstFileA(szResult, &wfd);
	    if (hFind != INVALID_HANDLE_VALUE) {
		FindClose(hFind);
		strcpy(pchReplace, wfd.cFileName);
		pchResult = pchReplace + strlen(pchReplace);
	    } else {
		/* Copy rest of input path & end. */
		strcat(pchResult, pchEnd);
		break;
	    }
	    pchScan = pchEnd;
	}
    }
    /* Copy it over */
    Tcl_ExternalToUtfDString(NULL, szResult, -1, dsPtr);
}
    
#endif


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces
 *	it, in place, with a normalized version.  On windows this
 *	means using the 'longname'.
 *
 * 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 ds;
    int pathLen;
    
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
	Tcl_DString eDs;
	char *nativePath;
	int nativeLen;

	Tcl_UtfToExternalDString(NULL, path, -1, &ds);
	nativePath = Tcl_DStringValue(&ds);
	nativeLen = Tcl_DStringLength(&ds);

	/* We're on Windows 95/98 */
	lastValidPathEnd = nativePath + Tcl_DStringLength(&ds);
	
	while (1) {
	    DWORD res = GetShortPathNameA(nativePath, nativePath, 1+nativeLen);
	    if (res != 0) {
		/* We found an ok path */
		break;
	    }
	    /* Undo the null-termination we put in before */
	    if (lastValidPathEnd != (nativePath + nativeLen)) {
		*lastValidPathEnd = '/';
	    }
	    /* 
	     * The path doesn't exist.  Back up the path, one component
	     * (directory/file) at a time, until one does exist. 
	     */
	    while (1) {
		char cur;
		lastValidPathEnd--;
		if (lastValidPathEnd == nativePath) {
		    /* We didn't accept any of the path */
		    Tcl_DStringFree(&ds);
		    return nextCheckpoint;
		}
		cur = *(lastValidPathEnd);
		if (cur == '/' || cur == '\\') {
		    /* Reached directory separator */
		    break;
		}
	    }
	    /* Temporarily terminate the string */
	    *lastValidPathEnd = '\0';
	}
	/* 
	 * If we get here, we found a valid path, which we've converted to
	 * short form, and the valid string ends at or before 'lastValidPathEnd'
	 * and the invalid string starts at 'lastValidPathEnd'.
	 */

	/* Copy over the valid part of the path and find its length */
	Tcl_ExternalToUtfDString(NULL, nativePath, -1, &eDs);
	path = Tcl_DStringValue(&eDs);
	if (path[1] == ':') {
	    if (path[0] >= 'a' && path[0] <= 'z') {
		/* Make uppercase */
	        path[0] -= 32;
	    }
	}
	nextCheckpoint = Tcl_DStringLength(&eDs);
	Tcl_SetStringObj(pathPtr, path, Tcl_DStringLength(&eDs));
	Tcl_DStringFree(&eDs);
	if (lastValidPathEnd != (nativePath + nativeLen)) {
	    CONST char *tmp;
	    *lastValidPathEnd = '/';
	    /* Now copy over the invalid (i.e. non-existent) part of the path */
	    tmp = Tcl_ExternalToUtfDString(NULL, lastValidPathEnd, -1, &eDs);
	    Tcl_AppendToObj(pathPtr, tmp, Tcl_DStringLength(&eDs));
	    Tcl_DStringFree(&eDs);
	}
	Tcl_DStringFree(&ds);
    } else {
	/* We're on WinNT or 2000 or XP */
	CONST char *nativePath;
#if 0
	/* 
	 * We don't use this simpler version, because the speed
	 * increase does not seem significant at present and the version
	 * below is thoroughly debugged.
	 */
	int nativeLen;
	Tcl_DString eDs;
	nativePath = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
	nativeLen = Tcl_DStringLength(&ds);
	WinGetLongPathName(nativePath, &eDs);
	/* 
	 * We need to add code here to calculate the new value of 
	 * 'nextCheckpoint' -- i.e. the longest part of the path
	 * which is an existing file.
	 */
	Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&eDs), Tcl_DStringLength(&eDs));
	Tcl_DStringFree(&eDs);
	Tcl_DStringFree(&ds);
#else
	char *currentPathEndPosition;
	WIN32_FILE_ATTRIBUTE_DATA data;
	nativePath = Tcl_WinUtfToTChar(path, -1, &ds);

	if ((*tclWinProcs->getFileAttributesExProc)(nativePath, 
						    GetFileExInfoStandard, 
						    &data) == TRUE) {
	    currentPathEndPosition = path + pathLen;
	    nextCheckpoint = pathLen;
	    lastValidPathEnd = currentPathEndPosition;
	    Tcl_DStringFree(&ds);
	} else {
	    Tcl_DStringFree(&ds);
	    currentPathEndPosition = path + nextCheckpoint;
	    while (1) {
		char cur = *currentPathEndPosition;
		if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
		    /* Reached directory separator, or end of string */
		    nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, 
						   &ds);
		    if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
			GetFileExInfoStandard, &data) != TRUE) {
			/* File doesn't exist */
			Tcl_DStringFree(&ds);
			break;
		    }
		    Tcl_DStringFree(&ds);

		    lastValidPathEnd = currentPathEndPosition;
		    /* File does exist */
		    if (cur == 0) {
			break;
		    }
		}
		currentPathEndPosition++;
	    }
	    nextCheckpoint = currentPathEndPosition - path;
	}
	if (lastValidPathEnd != NULL) {
	    Tcl_Obj *tmpPathPtr;
	    /* 
	     * The leading end of the path description was acceptable to
	     * us.  We therefore convert it to its long form, and return
	     * that.
	     */
	    Tcl_Obj* objPtr = NULL;
	    int endOfString;
	    int useLength = lastValidPathEnd - path;
	    if (*lastValidPathEnd == 0) {
		tmpPathPtr = Tcl_NewStringObj(path, useLength);
		endOfString = 1;
	    } else {
		tmpPathPtr = Tcl_NewStringObj(path, useLength + 1);
		endOfString = 0;
	    }
	    /* 
	     * If this returns an error, we have a strange situation; the
	     * file exists, but we can't get its long name.  We will have
	     * to assume the name we have is ok.
	     */
	    Tcl_IncrRefCount(tmpPathPtr);
	    if (ConvertFileNameFormat(interp, 0, tmpPathPtr, 1, &objPtr) == TCL_OK) {
		int len;
		(void) Tcl_GetStringFromObj(objPtr,&len);
		if (!endOfString) {
		    /* Be nice and fix the string before we clear it */
		    Tcl_AppendToObj(objPtr, lastValidPathEnd, -1);
		}
		nextCheckpoint += (len - useLength);
		path = Tcl_GetStringFromObj(objPtr,&len);
		Tcl_SetStringObj(pathPtr,path, len);
		Tcl_DecrRefCount(objPtr);
	    }
	    Tcl_DecrRefCount(tmpPathPtr);
	}
#endif
    }
    return nextCheckpoint;
}







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
1830
1831
1832
1833
1834
1835
1836

























































































































































































































































































	    Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
	}
    }
    
    Tcl_IncrRefCount(resultPtr);
    return resultPtr;
}

























































































































































































































































































Changes to win/tclWinFile.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16


17

18
19
20
21












































































































22
23
24
25
26
27
28
29
30
31
32




33
34
35
36



37
38







39



































































































































































































































































































































































































































40
41
42
43
44
45
46
/* 
 * tclWinFile.c --
 *
 *      This file contains temporary wrappers around UNIX file handling
 *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *      files, which can be manipulated through the Win32 console redirection
 *      interfaces.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFile.c,v 1.17.2.2 2002/06/10 05:33:19 wolfsuit Exp $
 */



#include "tclWinInt.h"

#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h>		/* For TclpGetUserHome(). */













































































































static time_t		ToCTime(FILETIME fileTime);

typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
	(LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);

typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
	(LPVOID Buffer);

typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
	(LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);





static int NativeAccess(CONST TCHAR *path, int mode);
static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr);
static int NativeIsExec(CONST TCHAR *path);
static int WinIsDrive(CONST char *name, int nameLen);



static int NativeMatchType(CONST char *name, int nameLen, 
			   CONST TCHAR* nativeName, Tcl_GlobTypeData *types);












































































































































































































































































































































































































































/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This procedure computes the absolute path name of the current













|


>
>

>




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











>
>
>
>

|

|
>
>
>


>
>
>
>
>
>
>

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
/* 
 * tclWinFile.c --
 *
 *      This file contains temporary wrappers around UNIX file handling
 *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
 *      files, which can be manipulated through the Win32 console redirection
 *      interfaces.
 *
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinFile.c,v 1.17.2.3 2002/08/20 20:25:31 das Exp $
 */

//#define _WIN32_WINNT  0x0500

#include "tclWinInt.h"
#include <winioctl.h>
#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h>		/* For TclpGetUserHome(). */

/*
 * Declarations for 'link' related information.  This information
 * should come with VC++ 6.0, but is not in some older SDKs.
 * In any case it is not well documented.
 */
#ifndef IO_REPARSE_TAG_RESERVED_ONE
#  define IO_REPARSE_TAG_RESERVED_ONE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_RESERVED_RANGE
#  define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_VALID_VALUES
#  define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
#endif
#ifndef IO_REPARSE_TAG_HSM
#  define IO_REPARSE_TAG_HSM 0x0C0000004
#endif
#ifndef IO_REPARSE_TAG_NSS
#  define IO_REPARSE_TAG_NSS 0x080000005
#endif
#ifndef IO_REPARSE_TAG_NSSRECOVER
#  define IO_REPARSE_TAG_NSSRECOVER 0x080000006
#endif
#ifndef IO_REPARSE_TAG_SIS
#  define IO_REPARSE_TAG_SIS 0x080000007
#endif
#ifndef IO_REPARSE_TAG_DFS
#  define IO_REPARSE_TAG_DFS 0x080000008
#endif

#ifndef IO_REPARSE_TAG_RESERVED_ZERO
#  define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
#endif
#ifndef FILE_FLAG_OPEN_REPARSE_POINT
#  define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
#endif
#ifndef IO_REPARSE_TAG_MOUNT_POINT
#  define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
#endif
#ifndef IsReparseTagValid
#  define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
#endif
#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
#  define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
#endif
#ifndef FILE_SPECIAL_ACCESS
#  define FILE_SPECIAL_ACCESS         (FILE_ANY_ACCESS)
#endif
#ifndef FSCTL_SET_REPARSE_POINT
#  define FSCTL_SET_REPARSE_POINT    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
#  define FSCTL_GET_REPARSE_POINT    CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) 
#  define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) 
#endif

/* 
 * Maximum reparse buffer info size. The max user defined reparse
 * data is 16KB, plus there's a header.
 */

#define MAX_REPARSE_SIZE	17000

/*
 * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition.
 * This is found in winnt.h.
 * 
 * IMPORTANT: caution when using this structure, since the actual
 * structures used will want to store a full path in the 'PathBuffer'
 * field, but there isn't room (there's only a single WCHAR!).  Therefore
 * one must artificially create a larger space of memory and then cast it
 * to this type.  We use the 'DUMMY_REPARSE_BUFFER' struct just below to
 * deal with this problem.
 */

#define REPARSE_MOUNTPOINT_HEADER_SIZE   8
#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
typedef struct _REPARSE_DATA_BUFFER {
    DWORD  ReparseTag;
    WORD   ReparseDataLength;
    WORD   Reserved;
    union {
        struct {
            WORD   SubstituteNameOffset;
            WORD   SubstituteNameLength;
            WORD   PrintNameOffset;
            WORD   PrintNameLength;
            WCHAR PathBuffer[1];
        } SymbolicLinkReparseBuffer;
        struct {
            WORD   SubstituteNameOffset;
            WORD   SubstituteNameLength;
            WORD   PrintNameOffset;
            WORD   PrintNameLength;
            WCHAR PathBuffer[1];
        } MountPointReparseBuffer;
        struct {
            BYTE   DataBuffer[1];
        } GenericReparseBuffer;
    };
} REPARSE_DATA_BUFFER;
#endif

typedef struct {
    REPARSE_DATA_BUFFER dummy;
    WCHAR  dummyBuf[MAX_PATH*3];
} DUMMY_REPARSE_BUFFER;

/* Other typedefs required by this code */

static time_t		ToCTime(FILETIME fileTime);

typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
	(LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);

typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
	(LPVOID Buffer);

typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
	(LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);

/*
 * Declarations for local procedures defined in this file:
 */

static int NativeAccess(CONST TCHAR *path, int mode);
static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks);
static int NativeIsExec(CONST TCHAR *path);
static int NativeReadReparse(CONST TCHAR* LinkDirectory, 
			     REPARSE_DATA_BUFFER* buffer);
static int NativeWriteReparse(CONST TCHAR* LinkDirectory, 
			      REPARSE_DATA_BUFFER* buffer);
static int NativeMatchType(CONST char *name, int nameLen, 
			   CONST TCHAR* nativeName, Tcl_GlobTypeData *types);
static int WinIsDrive(CONST char *name, int nameLen);
static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource);
static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory);
static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget, 
		   int linkAction);
static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, 
			       CONST TCHAR* LinkTarget);


/*
 *--------------------------------------------------------------------
 *
 * WinLink
 *
 * Make a link from source to target. 
 *--------------------------------------------------------------------
 */
static int 
WinLink(LinkSource, LinkTarget, linkAction)
    CONST TCHAR* LinkSource;
    CONST TCHAR* LinkTarget;
    int linkAction;
{
    WCHAR	tempFileName[MAX_PATH];
    TCHAR*	tempFilePart;
    int         attr;
    
    /* Get the full path referenced by the target */
    if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget, 
			  MAX_PATH, tempFileName, &tempFilePart)) {
	/* Invalid file */
	TclWinConvertError(GetLastError());
	return -1;
    }

    /* Make sure source file doesn't exist */
    attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
    if (attr != 0xffffffff) {
	Tcl_SetErrno(EEXIST);
	return -1;
    }

    /* Get the full path referenced by the directory */
    if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, 
			  MAX_PATH, tempFileName, &tempFilePart)) {
	/* Invalid file */
	TclWinConvertError(GetLastError());
	return -1;
    }
    /* Check the target */
    attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
    if (attr == 0xffffffff) {
	/* The target doesn't exist */
	TclWinConvertError(GetLastError());
	return -1;
    } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/* It is a file */
	if (tclWinProcs->createHardLinkProc == NULL) {
	    Tcl_SetErrno(ENOTDIR);
	    return -1;
	}
	if (linkAction & TCL_CREATE_HARD_LINK) {
	    if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
		TclWinConvertError(GetLastError());
		return -1;
	    }
	    return 0;
	} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    /* Can't symlink files */
	    Tcl_SetErrno(ENOTDIR);
	    return -1;
	} else {
	    Tcl_SetErrno(ENODEV);
	    return -1;
	}
    } else {
	if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
	    return WinSymLinkDirectory(LinkSource, LinkTarget);
	} else if (linkAction & TCL_CREATE_HARD_LINK) {
	    /* Can't hard link directories */
	    Tcl_SetErrno(EISDIR);
	    return -1;
	} else {
	    Tcl_SetErrno(ENODEV);
	    return -1;
	}
    }
}

/*
 *--------------------------------------------------------------------
 *
 * WinReadLink
 *
 * What does 'LinkSource' point to?  We need the original 'pathPtr'
 * just so we can construct a path object in the correct filesystem.
 *--------------------------------------------------------------------
 */
static Tcl_Obj* 
WinReadLink(LinkSource)
    CONST TCHAR* LinkSource;
{
    WCHAR	tempFileName[MAX_PATH];
    TCHAR*	tempFilePart;
    int         attr;
    
    /* Get the full path referenced by the target */
    if (!(*tclWinProcs->getFullPathNameProc)(LinkSource, 
			  MAX_PATH, tempFileName, &tempFilePart)) {
	/* Invalid file */
	TclWinConvertError(GetLastError());
	return NULL;
    }

    /* Make sure source file does exist */
    attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
    if (attr == 0xffffffff) {
	/* The source doesn't exist */
	TclWinConvertError(GetLastError());
	return NULL;
    } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
	/* It is a file - this is not yet supported */
	Tcl_SetErrno(ENOTDIR);
	return NULL;
    } else {
	return WinReadLinkDirectory(LinkSource);
    }
}

/*
 *--------------------------------------------------------------------
 *
 * WinSymLinkDirectory
 *
 * This routine creates a NTFS junction, using the undocumented
 * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points
 * and junctions.
 *
 * Assumption that LinkTarget is a valid, existing directory.
 * 
 * Returns zero on success.
 *--------------------------------------------------------------------
 */
static int 
WinSymLinkDirectory(LinkDirectory, LinkTarget)
    CONST TCHAR* LinkDirectory;
    CONST TCHAR* LinkTarget;
{
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    int         len;
    WCHAR       nativeTarget[MAX_PATH];
    WCHAR       *loop;
    
    /* Make the native target name */
    memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
    memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget, 
	   sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
    len = wcslen(nativeTarget);
    /* 
     * We must have backslashes only.  This is VERY IMPORTANT.
     * If we have any forward slashes everything appears to work,
     * but the resulting symlink is useless!
     */
    for (loop = nativeTarget; *loop != 0; loop++) {
	if (*loop == L'/') *loop = L'\\';
    }
    if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
	nativeTarget[len-1] = 0;
    }
    
    /* Build the reparse info */
    memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
    reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
    reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength = 
      wcslen(nativeTarget) * sizeof(WCHAR);
    reparseBuffer->Reserved = 0;
    reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
    reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset = 
      reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength 
      + sizeof(WCHAR);
    memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget, 
      sizeof(WCHAR) 
      + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
    reparseBuffer->ReparseDataLength = 
      reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
	
    return NativeWriteReparse(LinkDirectory, reparseBuffer);
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinSymLinkCopyDirectory
 *
 * Copy a Windows NTFS junction.  This function assumes that
 * LinkOriginal exists and is a valid junction point, and that
 * LinkCopy does not exist.
 * 
 * Returns zero on success.
 *--------------------------------------------------------------------
 */
int 
TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
    CONST TCHAR* LinkOriginal;  /* Existing junction - reparse point */
    CONST TCHAR* LinkCopy;      /* Will become a duplicate junction */
{
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    
    if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
	return -1;
    }
    return NativeWriteReparse(LinkCopy, reparseBuffer);
}

/*
 *--------------------------------------------------------------------
 *
 * TclWinSymLinkDelete
 *
 * Delete a Windows NTFS junction.  Once the junction information
 * is deleted, the filesystem object becomes an ordinary directory.
 * Unless 'linkOnly' is given, that directory is also removed.
 * 
 * Assumption that LinkOriginal is a valid, existing junction.
 * 
 * Returns zero on success.
 *--------------------------------------------------------------------
 */
int 
TclWinSymLinkDelete(LinkOriginal, linkOnly)
    CONST TCHAR* LinkOriginal;
    int linkOnly;
{
    /* It is a symbolic link -- remove it */
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    HANDLE hFile;
    int returnedLength;
    memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
    reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
    hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
	NULL, OPEN_EXISTING, 
	FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
    if (hFile != INVALID_HANDLE_VALUE) {
	if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, 
			     REPARSE_MOUNTPOINT_HEADER_SIZE,
			     NULL, 0, &returnedLength, NULL)) {	
	    /* Error setting junction */
	    TclWinConvertError(GetLastError());
	    CloseHandle(hFile);
	} else {
	    CloseHandle(hFile);
	    if (!linkOnly) {
	        (*tclWinProcs->removeDirectoryProc)(LinkOriginal);
	    }
	    return 0;
	}
    }
    return -1;
}

/*
 *--------------------------------------------------------------------
 *
 * WinReadLinkDirectory
 *
 * This routine reads a NTFS junction, using the undocumented
 * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points
 * and junctions.
 *
 * Assumption that LinkDirectory is a valid, existing directory.
 * 
 * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller).
 *--------------------------------------------------------------------
 */
static Tcl_Obj* 
WinReadLinkDirectory(LinkDirectory)
    CONST TCHAR* LinkDirectory;
{
    int attr;
    DUMMY_REPARSE_BUFFER dummy;
    REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
    
    attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
    if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	Tcl_SetErrno(EINVAL);
	return NULL;
    }
    if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
        return NULL;
    }
    
    switch (reparseBuffer->ReparseTag) {
	case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK: 
	case IO_REPARSE_TAG_SYMBOLIC_LINK: 
	case IO_REPARSE_TAG_MOUNT_POINT: {
	    Tcl_Obj *retVal;
	    Tcl_DString ds;
	    CONST char *copy;
	    int len;
	    
	    Tcl_WinTCharToUtf( 
		(CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, 
		(int)reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength, 
		&ds);
	
	    copy = Tcl_DStringValue(&ds);
	    len = Tcl_DStringLength(&ds);
	    /* 
	     * Certain native path representations on Windows have this special
	     * prefix to indicate that they are to be treated specially.  For
	     * example extremely long paths, or symlinks 
	     */
	    if (*copy == '\\') {
		if (0 == strncmp(copy,"\\??\\",4)) {
		    copy += 4;
		    len -= 4;
		} else if (0 == strncmp(copy,"\\\\?\\",4)) {
		    copy += 4;
		    len -= 4;
		}
	    }
	    retVal = Tcl_NewStringObj(copy,len);
	    Tcl_IncrRefCount(retVal);
	    Tcl_DStringFree(&ds);
	    return retVal;
	}
    }
    Tcl_SetErrno(EINVAL);
    return NULL;
}

/*
 *--------------------------------------------------------------------
 *
 * NativeReadReparse
 *
 * Read the junction/reparse information from a given NTFS directory.
 *
 * Assumption that LinkDirectory is a valid, existing directory.
 * 
 * Returns zero on success.
 *--------------------------------------------------------------------
 */
static int 
NativeReadReparse(LinkDirectory, buffer)
    CONST TCHAR* LinkDirectory;   /* The junction to read */
    REPARSE_DATA_BUFFER* buffer;  /* Pointer to buffer. Cannot be NULL */
{
    HANDLE hFile;
    int returnedLength;
   
    hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
	NULL, OPEN_EXISTING, 
	FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
    if (hFile == INVALID_HANDLE_VALUE) {
	/* Error creating directory */
	TclWinConvertError(GetLastError());
	return -1;
    }
    /* Get the link */
    if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, 
			 0, buffer, sizeof(DUMMY_REPARSE_BUFFER), 
			 &returnedLength, NULL)) {	
	/* Error setting junction */
	TclWinConvertError(GetLastError());
	CloseHandle(hFile);
	return -1;
    }
    CloseHandle(hFile);
    
    if (!IsReparseTagValid(buffer->ReparseTag)) {
	Tcl_SetErrno(EINVAL);
	return -1;
    }
    return 0;
}

/*
 *--------------------------------------------------------------------
 *
 * NativeWriteReparse
 *
 * Write the reparse information for a given directory.
 * 
 * Assumption that LinkDirectory does not exist.
 *--------------------------------------------------------------------
 */
static int 
NativeWriteReparse(LinkDirectory, buffer)
    CONST TCHAR* LinkDirectory;
    REPARSE_DATA_BUFFER* buffer;
{
    HANDLE hFile;
    int returnedLength;
    
    /* Create the directory - it must not already exist */
    if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {
	/* Error creating directory */
	TclWinConvertError(GetLastError());
	return -1;
    }
    hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
	NULL, OPEN_EXISTING, 
	FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
    if (hFile == INVALID_HANDLE_VALUE) {
	/* Error creating directory */
	TclWinConvertError(GetLastError());
	return -1;
    }
    /* Set the link */
    if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer, 
			 buffer->ReparseDataLength 
			 + REPARSE_MOUNTPOINT_HEADER_SIZE,
			 NULL, 0, &returnedLength, NULL)) {	
	/* Error setting junction */
	TclWinConvertError(GetLastError());
	CloseHandle(hFile);
	(*tclWinProcs->removeDirectoryProc)(LinkDirectory);
	return -1;
    }
    CloseHandle(hFile);
    /* We succeeded */
    return 0;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpFindExecutable --
 *
 *	This procedure computes the absolute path name of the current
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
		) {
		return 0;
	    }
	}
	if (types->type != 0) {
	    Tcl_StatBuf buf;
	    
	    if (NativeStat(nativeName, &buf) != 0) {
		/* 
		 * Posix error occurred, either the file
		 * has disappeared, or there is some other
		 * strange error.  In any case we don't
		 * return this file.
		 */
		return 0;







|







1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
		) {
		return 0;
	    }
	}
	if (types->type != 0) {
	    Tcl_StatBuf buf;
	    
	    if (NativeStat(nativeName, &buf, 0) != 0) {
		/* 
		 * Posix error occurred, either the file
		 * has disappeared, or there is some other
		 * strange error.  In any case we don't
		 * return this file.
		 */
		return 0;
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
			S_ISSOCK(buf.st_mode))
#endif
		) {
		/* Do nothing -- this file is ok */
	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {
		    /* 
		     * We should use 'lstat' but it is the
		     * same as 'stat' on windows.
		     */
		    if (NativeStat(nativeName, &buf) == 0) {
			if (S_ISLNK(buf.st_mode)) {
			    return 1;
			}
		    }
		}
#endif
		return 0;







<
<
<
<
|







1064
1065
1066
1067
1068
1069
1070




1071
1072
1073
1074
1075
1076
1077
1078
			S_ISSOCK(buf.st_mode))
#endif
		) {
		/* Do nothing -- this file is ok */
	    } else {
#ifdef S_ISLNK
		if (types->type & TCL_GLOB_TYPE_LINK) {




		    if (NativeStat(nativeName, &buf, 1) == 0) {
			if (S_ISLNK(buf.st_mode)) {
			    return 1;
			}
		    }
		}
#endif
		return 0;
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
    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__ */








|







1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
    Tcl_DString ds;

    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
    length = readlink(native, link, sizeof(link));     /* INTL: Native. */
    Tcl_DStringFree(&ds);
    
    if (length < 0) {
	return NULL;
    }

    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
    return Tcl_DStringValue(linkPtr);
}
#endif /* __CYGWIN__ */

945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
     * 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);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStat --
 *







|







1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
     * Ensure correct file sizes by forcing the OS to write any
     * pending data to disk. This is done only for channels which are
     * dirty, i.e. have been written to since the last flush here.
     */

    TclWinFlushDirtyChannels ();

    return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}

/*
 *----------------------------------------------------------------------
 *
 * NativeStat --
 *
972
973
974
975
976
977
978
979
980
981

982
983
984
985
986
987
988
 * Side effects:
 *	See stat documentation.
 *
 *----------------------------------------------------------------------
 */

static int 
NativeStat(nativePath, statPtr)
    CONST TCHAR *nativePath;   /* Path of file to stat */
    Tcl_StatBuf *statPtr;      /* Filled with results of stat call. */

{
    Tcl_DString ds;
    DWORD attr;
    WCHAR nativeFullPath[MAX_PATH];
    TCHAR *nativePart;
    CONST char *fullPath;
    int dev, mode;







|


>







1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
 * Side effects:
 *	See stat documentation.
 *
 *----------------------------------------------------------------------
 */

static int 
NativeStat(nativePath, statPtr, checkLinks)
    CONST TCHAR *nativePath;   /* Path of file to stat */
    Tcl_StatBuf *statPtr;      /* Filled with results of stat call. */
    int checkLinks;            /* If non-zero, behave like 'lstat' */
{
    Tcl_DString ds;
    DWORD attr;
    WCHAR nativeFullPath[MAX_PATH];
    TCHAR *nativePart;
    CONST char *fullPath;
    int dev, mode;
1130
1131
1132
1133
1134
1135
1136




1137

1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
	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  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;

    mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
    if (NativeIsExec(nativePath)) {
	mode |= S_IEXEC;
    }

    /*
     * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and 
     * other positions.
     */

    mode |= (mode & 0x0700) >> 3;
    mode |= (mode & 0x0700) >> 6;







>
>
>
>
|
>




|







1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
	statPtr->st_size  = ((Tcl_WideInt)data.nFileSizeLow) |
		(((Tcl_WideInt)data.nFileSizeHigh) << 32);
	statPtr->st_atime = ToCTime(data.ftLastAccessTime);
	statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
	statPtr->st_ctime = ToCTime(data.ftCreationTime);
    }

    if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
	/* It is a link */
	mode = S_IFLNK;
    } else {
	mode  = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
    }
    mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
    if (NativeIsExec(nativePath)) {
	mode |= S_IEXEC;
    }
    
    /*
     * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and 
     * other positions.
     */

    mode |= (mode & 0x0700) >> 3;
    mode |= (mode & 0x0700) >> 6;
1308
1309
1310
1311
1312
1313
1314
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
    Tcl_Obj *pathPtr;
    int mode;
{
    return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
}

int 
TclpObjLstat(pathPtr, buf)
    Tcl_Obj *pathPtr;
    Tcl_StatBuf *buf; 
{





    return TclpObjStat(pathPtr,buf);



}

#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;

{





    Tcl_Obj* link = NULL;



    if (toPtr != NULL) {

	return NULL;

    } else {
	Tcl_DString ds;
	if (TclpReadlink(Tcl_FSGetTranslatedStringPath(NULL, pathPtr), &ds) 
	  != NULL) {
	    link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
	    Tcl_IncrRefCount(link);
	    Tcl_DStringFree(&ds);
	}

    }
    return link;
}

#endif


/*
 *---------------------------------------------------------------------------







|

|

>
>
>
>
>
|
>
>
>





|


>

>
>
>
>
>
|
|
>
>
|
>
|
>

<
|
|
<
<
|

>

<







1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899


1900
1901
1902
1903

1904
1905
1906
1907
1908
1909
1910
    Tcl_Obj *pathPtr;
    int mode;
{
    return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
}

int 
TclpObjLstat(pathPtr, statPtr)
    Tcl_Obj *pathPtr;
    Tcl_StatBuf *statPtr; 
{
    /*
     * Ensure correct file sizes by forcing the OS to write any
     * pending data to disk. This is done only for channels which are
     * dirty, i.e. have been written to since the last flush here.
     */

    TclWinFlushDirtyChannels ();

    return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}

#ifdef S_IFLNK

Tcl_Obj* 
TclpObjLink(pathPtr, toPtr, linkAction)
    Tcl_Obj *pathPtr;
    Tcl_Obj *toPtr;
    int linkAction;
{
    if (toPtr != NULL) {
	int res;
	TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
	TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
	if (LinkSource == NULL || LinkTarget == NULL) {
	    return NULL;
	}
	res = WinLink(LinkSource, LinkTarget, linkAction);
	if (res == 0) {
	    return toPtr;
	} else {
	    return NULL;
	}
    } else {

	TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
	if (LinkSource == NULL) {


	    return NULL;
	}
	return WinReadLink(LinkSource);
    }

}

#endif


/*
 *---------------------------------------------------------------------------
1400
1401
1402
1403
1404
1405
1406

































































































































































































































































	Tcl_WinTCharToUtf(volType, -1, &ds);
	objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	return objPtr;
    }
#undef VOL_BUF_SIZE
}








































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
	Tcl_WinTCharToUtf(volType, -1, &ds);
	objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
	Tcl_DStringFree(&ds);
	return objPtr;
    }
#undef VOL_BUF_SIZE
}


/*
 *---------------------------------------------------------------------------
 *
 * TclpObjNormalizePath --
 *
 *	This function scans through a path specification and replaces it,
 *	in place, with a normalized version.  This means using the
 *	'longname', and expanding any symbolic links contained within the
 *	path.
 *
 * Results:
 *	The new 'nextCheckpoint' value, giving as far as we could
 *	understand in the path.
 *
 * Side effects:
 *	The pathPtr string, which must contain a valid path, is
 *	possibly modified in place.
 *
 *---------------------------------------------------------------------------
 */

int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
    Tcl_Interp *interp;
    Tcl_Obj *pathPtr;
    int nextCheckpoint;
{
    char *lastValidPathEnd = NULL;
    /* This will hold the normalized string */
    Tcl_DString dsNorm;
    char *path;
    char *currentPathEndPosition;

    Tcl_DStringInit(&dsNorm);
    path = Tcl_GetString(pathPtr);

    if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
	/* 
	 * We're on Win95, 98 or ME.  There are two assumptions
	 * in this block of code.  First that the native (NULL)
	 * encoding is basically ascii, and second that symbolic
	 * links are not possible.  Both of these assumptions
	 * appear to be true of these operating systems.
	 */
	Tcl_Obj *temp = NULL;
	int isDrive = 1;
	Tcl_DString ds;

	currentPathEndPosition = path + nextCheckpoint;
	while (1) {
	    char cur = *currentPathEndPosition;
	    if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
		/* Reached directory separator, or end of string */
		CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path, 
			    currentPathEndPosition - path, &ds);

		/*
		 * Now we convert the tail of the current path to its
		 * 'long form', and append it to 'dsNorm' which holds
		 * the current normalized path, if the file exists.
		 */
		if (isDrive) {
		    if (GetFileAttributesA(nativePath) 
			== 0xffffffff) {
			/* File doesn't exist */
			Tcl_DStringFree(&ds);
			break;
		    }
		    if (nativePath[0] >= 'a') {
			((char*)nativePath)[0] -= ('a' - 'A');
		    }
		    Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
		} else {
		    WIN32_FIND_DATA fData;
		    HANDLE handle;
		    
		    handle = FindFirstFileA(nativePath, &fData);
		    if (handle == INVALID_HANDLE_VALUE) {
			if (GetFileAttributesA(nativePath) 
			    == 0xffffffff) {
			    /* File doesn't exist */
			    Tcl_DStringFree(&ds);
			    break;
			}
			/* This is usually the '/' in 'c:/' at end of string */
			Tcl_DStringAppend(&dsNorm,"/", 1);
		    } else {
			char *nativeName;
			if (fData.cFileName[0] != '\0') {
			    nativeName = fData.cFileName;
			} else {
			    nativeName = fData.cAlternateFileName;
			}
			FindClose(handle);
			Tcl_DStringAppend(&dsNorm,"/", 1);
			Tcl_DStringAppend(&dsNorm,nativeName,-1);
		    }
		}
		Tcl_DStringFree(&ds);
		lastValidPathEnd = currentPathEndPosition;
		if (cur == 0) {
		    break;
		}
		/* 
		 * If we get here, we've got past one directory
		 * delimiter, so we know it is no longer a drive 
		 */
		isDrive = 0;
	    }
	    currentPathEndPosition++;
	}
    } else {
	/* We're on WinNT or 2000 or XP */
	Tcl_Obj *temp = NULL;
	int isDrive = 1;
	Tcl_DString ds;

	currentPathEndPosition = path + nextCheckpoint;
	while (1) {
	    char cur = *currentPathEndPosition;
	    if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
		/* Reached directory separator, or end of string */
		WIN32_FILE_ATTRIBUTE_DATA data;
		CONST char *nativePath = Tcl_WinUtfToTChar(path, 
			    currentPathEndPosition - path, &ds);
		if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
		    GetFileExInfoStandard, &data) != TRUE) {
		    /* File doesn't exist */
		    Tcl_DStringFree(&ds);
		    break;
		}

		/* 
		 * File 'nativePath' does exist if we get here.  We
		 * now want to check if it is a symlink and otherwise
		 * continue with the rest of the path.
		 */
		
		/* 
		 * Check for symlinks, except at last component
		 * of path (we don't follow final symlinks). Also
		 * a drive (C:/) for example, may sometimes have
		 * the reparse flag set for some reason I don't
		 * understand.  We therefore don't perform this
		 * check for drives.
		 */
		if (cur != 0 && !isDrive && (data.dwFileAttributes 
				 & FILE_ATTRIBUTE_REPARSE_POINT)) {
		    Tcl_Obj *to = WinReadLinkDirectory(nativePath);
		    if (to != NULL) {
			/* Read the reparse point ok */
			/* Tcl_GetStringFromObj(to, &pathLen); */
			nextCheckpoint = 0; /* pathLen */
			Tcl_AppendToObj(to, currentPathEndPosition, -1);
			/* Convert link to forward slashes */
			for (path = Tcl_GetString(to); *path != 0; path++) {
			    if (*path == '\\') *path = '/';
			}
			path = Tcl_GetString(to);
			currentPathEndPosition = path + nextCheckpoint;
			if (temp != NULL) {
			    Tcl_DecrRefCount(temp);
			}
			temp = to;
			/* Reset variables so we can restart normalization */
			isDrive = 1;
			Tcl_DStringFree(&dsNorm);
			Tcl_DStringInit(&dsNorm);
			Tcl_DStringFree(&ds);
			continue;
		    }
		}
		/*
		 * Now we convert the tail of the current path to its
		 * 'long form', and append it to 'dsNorm' which holds
		 * the current normalized path
		 */
		if (isDrive) {
		    WCHAR drive = ((WCHAR*)nativePath)[0];
		    if (drive >= L'a') {
		        drive -= (L'a' - L'A');
			((WCHAR*)nativePath)[0] = drive;
		    }
		    Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
		} else {
		    WIN32_FIND_DATAW fData;
		    HANDLE handle;
		    
		    handle = FindFirstFileW((WCHAR*)nativePath, &fData);
		    if (handle == INVALID_HANDLE_VALUE) {
			/* This is usually the '/' in 'c:/' at end of string */
			Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", 
					  sizeof(WCHAR));
		    } else {
			WCHAR *nativeName;
			if (fData.cFileName[0] != '\0') {
			    nativeName = fData.cFileName;
			} else {
			    nativeName = fData.cAlternateFileName;
			}
			FindClose(handle);
			Tcl_DStringAppend(&dsNorm,(CONST char*)L"/", 
					  sizeof(WCHAR));
			Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName, 
					  wcslen(nativeName)*sizeof(WCHAR));
		    }
		}
		Tcl_DStringFree(&ds);
		lastValidPathEnd = currentPathEndPosition;
		if (cur == 0) {
		    break;
		}
		/* 
		 * If we get here, we've got past one directory
		 * delimiter, so we know it is no longer a drive 
		 */
		isDrive = 0;
	    }
	    currentPathEndPosition++;
	}
    }
    /* Common code path for all Windows platforms */
    nextCheckpoint = currentPathEndPosition - path;
    if (lastValidPathEnd != NULL) {
	/* 
	 * Concatenate the normalized string in dsNorm with the
	 * tail of the path which we didn't recognise.  The
	 * string in dsNorm is in the native encoding, so we
	 * have to convert it to Utf.
	 */
	Tcl_DString dsTemp;
	Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm), 
			  Tcl_DStringLength(&dsNorm), &dsTemp);
	nextCheckpoint = Tcl_DStringLength(&dsTemp);
	if (*lastValidPathEnd != 0) {
	    /* Not the end of the string */
	    int len;
	    char *path;
	    Tcl_Obj *tmpPathPtr;
	    tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), 
					  nextCheckpoint);
	    Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
	    path = Tcl_GetStringFromObj(tmpPathPtr, &len);
	    Tcl_SetStringObj(pathPtr, path, len);
	    Tcl_DecrRefCount(tmpPathPtr);
	} else {
	    /* End of string was reached above */
	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
			     nextCheckpoint);
	}
	Tcl_DStringFree(&dsTemp);
    }
    Tcl_DStringFree(&dsNorm);
    return nextCheckpoint;
}
Changes to win/tclWinInt.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclWinInt.h --
 *
 *	Declarations of Windows-specific shared variables and procedures.
 *
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinInt.h,v 1.11.6.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#ifndef _TCLWININT
#define _TCLWININT

#ifndef _TCLINT
#include "tclInt.h"










|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
/*
 * tclWinInt.h --
 *
 *	Declarations of Windows-specific shared variables and procedures.
 *
 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinInt.h,v 1.11.6.3 2002/08/20 20:25:31 das Exp $
 */

#ifndef _TCLWININT
#define _TCLWININT

#ifndef _TCLINT
#include "tclInt.h"
87
88
89
90
91
92
93
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
    BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
    DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *, 
	    CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
    BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
    BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
    BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *, 
	    GET_FILEEX_INFO_LEVELS, LPVOID);


} TclWinProcs;

EXTERN TclWinProcs *tclWinProcs;

/*
 * Declarations of functions that are not accessible by way of the
 * stubs table.
 */

EXTERN void		TclWinInit(HINSTANCE hInst);




#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
EXTERN void		TclWinFreeAllocCache(void);
EXTERN void		TclFreeAllocCache(void *);
EXTERN Tcl_Mutex	*TclpNewAllocMutex(void);
EXTERN void		*TclpGetAllocCache(void);
EXTERN void		TclpSetAllocCache(void *);
#endif /* TCL_THREADS */






#include "tclIntPlatDecls.h"

# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT

#endif	/* _TCLWININT */







|
>










>
>
>
>







>
>
>
>
>







87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
    BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
    DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *, 
	    CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
    BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
    BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
    BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *, 
	    GET_FILEEX_INFO_LEVELS, LPVOID);
    BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*, 
				      LPSECURITY_ATTRIBUTES);
} TclWinProcs;

EXTERN TclWinProcs *tclWinProcs;

/*
 * Declarations of functions that are not accessible by way of the
 * stubs table.
 */

EXTERN void		TclWinInit(HINSTANCE hInst);
EXTERN int              TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal,
						   CONST TCHAR* LinkCopy);
EXTERN int              TclWinSymLinkDelete(CONST TCHAR* LinkOriginal, 
					    int linkOnly);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
EXTERN void		TclWinFreeAllocCache(void);
EXTERN void		TclFreeAllocCache(void *);
EXTERN Tcl_Mutex	*TclpNewAllocMutex(void);
EXTERN void		*TclpGetAllocCache(void);
EXTERN void		TclpSetAllocCache(void *);
#endif /* TCL_THREADS */

/* Needed by tclWinFile.c and tclWinFCmd.c */
#ifndef FILE_ATTRIBUTE_REPARSE_POINT
#define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400
#endif

#include "tclIntPlatDecls.h"

# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT

#endif	/* _TCLWININT */
Changes to win/tclWinLoad.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
/* 
 * tclWinLoad.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the Windows "LoadLibrary" and "GetProcAddress"
 *	API for dynamic loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinLoad.c,v 1.9.2.1 2002/02/05 02:22:05 wolfsuit Exp $
 */

#include "tclWinInt.h"


/*
 *----------------------------------------------------------------------
 *
 * TclpLoadFile --
 *
 *	Dynamically loads a binary code file into memory and returns
 *	the addresses of two procedures within that file, if they
 *	are defined.
 *
 * 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
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. */
    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. */
{
    HINSTANCE handle;
    CONST TCHAR *nativeName;
    Tcl_DString ds;

    char *fileName = Tcl_GetString(pathPtr);
    nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
    handle = (*tclWinProcs->loadLibraryProc)(nativeName);
    Tcl_DStringFree(&ds);

    *clientDataPtr = (ClientData) 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...












|








|


<
|












<
|


|
<
<
<
<
<
|
















|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
35
36
37

38
39
40
41





42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
/* 
 * tclWinLoad.c --
 *
 *	This procedure provides a version of the TclLoadFile that
 *	works with the Windows "LoadLibrary" and "GetProcAddress"
 *	API for dynamic loading.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinLoad.c,v 1.9.2.2 2002/08/20 20:25:31 das Exp $
 */

#include "tclWinInt.h"


/*
 *----------------------------------------------------------------------
 *
 * TclpDlopen --
 *
 *	Dynamically loads a binary code file into memory and returns

 *	a handle to the new code.
 *
 * Results:
 *	A standard Tcl completion code.  If an error occurs, an error
 *	message is left in the interp's result.
 *
 * Side effects:
 *	New code suddenly appears in memory.
 *
 *----------------------------------------------------------------------
 */

int

TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
    Tcl_Interp *interp;		/* Used for error reporting. */
    Tcl_Obj *pathPtr;		/* Name of the file containing the desired
				 * code (UTF-8). */





    Tcl_LoadHandle *loadHandle;	/* Filled with token for dynamically loaded
				 * file which will be passed back to 
				 * (*unloadProcPtr)() to unload the file. */
    Tcl_FSUnloadFileProc **unloadProcPtr;	
				/* Filled with address of Tcl_FSUnloadFileProc
				 * function which should be used for
				 * this file. */
{
    HINSTANCE handle;
    CONST TCHAR *nativeName;
    Tcl_DString ds;

    char *fileName = Tcl_GetString(pathPtr);
    nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
    handle = (*tclWinProcs->loadLibraryProc)(nativeName);
    Tcl_DStringFree(&ds);

    *loadHandle = (Tcl_LoadHandle) handle;
    
    if (handle == NULL) {
	DWORD lastError = GetLastError();
#if 0
	/*
	 * It would be ideal if the FormatMessage stuff worked better,
	 * but unfortunately it doesn't seem to want to...
113
114
115
116
117
118
119



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
		Tcl_AppendResult(interp, Tcl_PosixError(interp),
			(char *) NULL);
	}
	return TCL_ERROR;
    } else {
	*unloadProcPtr = &TclpUnloadFile;
    }



    /*
























     * For each symbol, check for both Symbol and _Symbol, since Borland
     * generates C symbols with a leading '_' by default.
     */

    *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
    if (*proc1Ptr == NULL) {
	Tcl_DStringAppend(&ds, "_", 1);
	sym1 = Tcl_DStringAppend(&ds, sym1, -1);
	*proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
	Tcl_DStringFree(&ds);
    }
    
    *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
    if (*proc2Ptr == NULL) {
	Tcl_DStringAppend(&ds, "_", 1);
	sym2 = Tcl_DStringAppend(&ds, sym2, -1);
	*proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
	Tcl_DStringFree(&ds);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *







>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




|
|
|
<
<
|
<
<
<
<

|
|


|







106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147


148




149
150
151
152
153
154
155
156
157
158
159
160
161
		Tcl_AppendResult(interp, Tcl_PosixError(interp),
			(char *) NULL);
	}
	return TCL_ERROR;
    } else {
	*unloadProcPtr = &TclpUnloadFile;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpFindSymbol --
 *
 *	Looks up a symbol, by name, through a handle associated with
 *	a previously loaded piece of code (shared library).
 *
 * Results:
 *	Returns a pointer to the function associated with 'symbol' if
 *	it is found.  Otherwise returns NULL and may leave an error
 *	message in the interp's result.
 *
 *----------------------------------------------------------------------
 */
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol) 
    Tcl_Interp *interp;
    Tcl_LoadHandle loadHandle;
    CONST char *symbol;
{
    Tcl_PackageInitProc *proc = NULL;
    HINSTANCE handle = (HINSTANCE)loadHandle;

    /*
     * For each symbol, check for both Symbol and _Symbol, since Borland
     * generates C symbols with a leading '_' by default.
     */

    proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
    if (proc == NULL) {
	Tcl_DString ds;


	Tcl_DStringInit(&ds);




	Tcl_DStringAppend(&ds, "_", 1);
	symbol = Tcl_DStringAppend(&ds, symbol, -1);
	proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
	Tcl_DStringFree(&ds);
    }
    return proc;
}

/*
 *----------------------------------------------------------------------
 *
 * TclpUnloadFile --
 *
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(clientData)
    ClientData clientData;	/* ClientData returned by a previous call
				 * to TclpLoadFile().  The clientData is 
				 * a token that represents the loaded 
				 * file. */
{
    HINSTANCE handle;

    handle = (HINSTANCE) clientData;
    FreeLibrary(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --







|
|
|





|







169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
 * Side effects:
 *	Code removed from memory.
 *
 *----------------------------------------------------------------------
 */

void
TclpUnloadFile(loadHandle)
    Tcl_LoadHandle loadHandle;	/* loadHandle returned by a previous call
				 * to TclpDlopen().  The loadHandle is 
				 * a token that represents the loaded 
				 * file. */
{
    HINSTANCE handle;

    handle = (HINSTANCE) loadHandle;
    FreeLibrary(handle);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGuessPackageName --
Changes to win/tclWinPipe.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWinPipe.c --
 *
 *	This file implements the Windows-specific exec pipeline functions,
 *	the "pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPipe.c,v 1.20.8.2 2002/06/10 05:33:19 wolfsuit Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
/* 
 * tclWinPipe.c --
 *
 *	This file implements the Windows-specific exec pipeline functions,
 *	the "pipe" channel driver, and the "pid" Tcl command.
 *
 * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPipe.c,v 1.20.8.3 2002/08/20 20:25:31 das Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>
1587
1588
1589
1590
1591
1592
1593





1594
1595
1596
1597
1598
1599
1600
		Tcl_DStringAppend(&ds, start, special - start);
		start = special;
	    }
	    if (*special == '"') {
		Tcl_DStringAppend(&ds, start, special - start);
		Tcl_DStringAppend(&ds, "\\\"", 2);
		start = special + 1;





	    }
	    if (*special == '\0') {
		break;
	    }
	    special++;
	}
	Tcl_DStringAppend(&ds, start, special - start);







>
>
>
>
>







1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
		Tcl_DStringAppend(&ds, start, special - start);
		start = special;
	    }
	    if (*special == '"') {
		Tcl_DStringAppend(&ds, start, special - start);
		Tcl_DStringAppend(&ds, "\\\"", 2);
		start = special + 1;
	    }
	    if (*special == '{') {
		Tcl_DStringAppend(&ds, start, special - start);
		Tcl_DStringAppend(&ds, "\\{", 2);
		start = special + 1;
	    }
	    if (*special == '\0') {
		break;
	    }
	    special++;
	}
	Tcl_DStringAppend(&ds, start, special - start);
Changes to win/tclWinPort.h.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclWinPort.h --
 *
 *	This header file handles porting issues that occur because of
 *	differences between Windows and Unix. It should be the only
 *	file that contains #ifdefs to handle different flavors of OS.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPort.h,v 1.23.2.2 2002/06/10 05:33:20 wolfsuit Exp $
 */

#ifndef _TCLWINPORT
#define _TCLWINPORT

#ifndef _TCLINT
#   include "tclInt.h"












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclWinPort.h --
 *
 *	This header file handles porting issues that occur because of
 *	differences between Windows and Unix. It should be the only
 *	file that contains #ifdefs to handle different flavors of OS.
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinPort.h,v 1.23.2.3 2002/08/20 20:25:31 das Exp $
 */

#ifndef _TCLWINPORT
#define _TCLWINPORT

#ifndef _TCLINT
#   include "tclInt.h"
278
279
280
281
282
283
284




285
286
287
288
289
290
291
#    define R_OK 04
#endif

/*
 * Define macros to query file type bits, if they're not already
 * defined.
 */





#ifndef S_ISREG
#   ifdef S_IFREG
#       define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
#   else
#       define S_ISREG(m) 0
#   endif







>
>
>
>







278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
#    define R_OK 04
#endif

/*
 * Define macros to query file type bits, if they're not already
 * defined.
 */

#ifndef S_IFLNK
#define S_IFLNK        0120000  /* Symbolic Link */
#endif

#ifndef S_ISREG
#   ifdef S_IFREG
#       define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
#   else
#       define S_ISREG(m) 0
#   endif
314
315
316
317
318
319
320








321
322
323
324
325
326
327
#ifndef S_ISFIFO
#   ifdef S_IFIFO
#       define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
#   else
#       define S_ISFIFO(m) 0
#   endif
#endif /* !S_ISFIFO */









/*
 * Define MAXPATHLEN in terms of MAXPATH if available
 */

#ifndef MAXPATH
#define MAXPATH MAX_PATH







>
>
>
>
>
>
>
>







318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
#ifndef S_ISFIFO
#   ifdef S_IFIFO
#       define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
#   else
#       define S_ISFIFO(m) 0
#   endif
#endif /* !S_ISFIFO */
#ifndef S_ISLNK
#   ifdef S_IFLNK
#       define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
#   else
#       define S_ISLNK(m) 0
#   endif
#endif /* !S_ISLNK */


/*
 * Define MAXPATHLEN in terms of MAXPATH if available
 */

#ifndef MAXPATH
#define MAXPATH MAX_PATH
426
427
428
429
430
431
432



433
434
435
436
437
438
439
 * file tclWinSock.c).
 */

#define getservbyname	TclWinGetServByName
#define getsockopt	TclWinGetSockOpt
#define ntohs		TclWinNToHS
#define setsockopt	TclWinSetSockOpt




/*
 * The following macros have trivial definitions, allowing generic code to 
 * address platform-specific issues.
 */

#define TclpReleaseFile(file)	ckfree((char *) file)







>
>
>







438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
 * file tclWinSock.c).
 */

#define getservbyname	TclWinGetServByName
#define getsockopt	TclWinGetSockOpt
#define ntohs		TclWinNToHS
#define setsockopt	TclWinSetSockOpt
/* This type is not defined in the Windows headers */
#define socklen_t       int


/*
 * The following macros have trivial definitions, allowing generic code to 
 * address platform-specific issues.
 */

#define TclpReleaseFile(file)	ckfree((char *) file)
Changes to win/tclWinSerial.c.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinSerial.c --
 *
 *  This file implements the Windows-specific serial port functions,
 *  and the "serial" channel driver.
 *
 * Copyright (c) 1999 by Scriptics Corp.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * Serial functionality implemented by Rolf.Schroedter@dlr.de
 *
 * RCS: @(#) $Id: tclWinSerial.c,v 1.13.8.1 2002/06/10 05:33:20 wolfsuit Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>













|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/*
 * tclWinSerial.c --
 *
 *  This file implements the Windows-specific serial port functions,
 *  and the "serial" channel driver.
 *
 * Copyright (c) 1999 by Scriptics Corp.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * Serial functionality implemented by Rolf.Schroedter@dlr.de
 *
 * RCS: @(#) $Id: tclWinSerial.c,v 1.13.8.2 2002/08/20 20:25:31 das Exp $
 */

#include "tclWinInt.h"

#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>
143
144
145
146
147
148
149

150



151
152
153
154
155
156
157
                             * 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;


COMMTIMEOUTS no_timeout  = {   /* We don't use timeouts */



    0,               /* ReadIntervalTimeout */
    0,               /* ReadTotalTimeoutMultiplier */
    0,               /* ReadTotalTimeoutConstant */
    0,               /* WriteTotalTimeoutMultiplier */
    0,               /* WriteTotalTimeoutConstant */
};








>
|
>
>
>







143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
                             * all events. */
    SerialInfo *infoPtr;    /* Pointer to serial info structure.  Note
                             * that we still have to verify that the
                             * serial exists before dereferencing this
                             * pointer. */
} SerialEvent;

/*
 * We don't use timeouts.
 */

static COMMTIMEOUTS no_timeout = {
    0,               /* ReadIntervalTimeout */
    0,               /* ReadTotalTimeoutMultiplier */
    0,               /* ReadTotalTimeoutConstant */
    0,               /* WriteTotalTimeoutMultiplier */
    0,               /* WriteTotalTimeoutConstant */
};

Changes to win/tclWinTest.c.
1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20
/* 
 * tclWinTest.c --
 *
 *	Contains commands for platform specific tests on Windows.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinTest.c,v 1.5.14.1 2002/02/05 02:22:05 wolfsuit Exp $
 */


#include "tclWinInt.h"

/*
 * Forward declarations of procedures defined later in this file:
 */
int		TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
static int	TesteventloopCmd _ANSI_ARGS_((ClientData dummy,










|


>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
/* 
 * tclWinTest.c --
 *
 *	Contains commands for platform specific tests on Windows.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinTest.c,v 1.5.14.2 2002/08/20 20:25:31 das Exp $
 */

#define USE_COMPAT_CONST
#include "tclWinInt.h"

/*
 * Forward declarations of procedures defined later in this file:
 */
int		TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
static int	TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
Changes to win/tclsh.rc.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
// RCS: @(#) $Id: tclsh.rc,v 1.7 2001/10/01 20:57:20 hobbs Exp $
//
// Version Resource Script
//

#include <winver.h>

#define RESOURCE_INCLUDED
#include <tcl.h>

//
// build-up the name suffix that defines the type of build this is.
//
#ifdef TCL_THREADS
#define SUFFIX_THREADS	    "t"
|





<
<







1
2
3
4
5
6


7
8
9
10
11
12
13
// RCS: @(#) $Id: tclsh.rc,v 1.7.2.1 2002/08/20 20:25:31 das Exp $
//
// Version Resource Script
//

#include <winver.h>


#include <tcl.h>

//
// build-up the name suffix that defines the type of build this is.
//
#ifdef TCL_THREADS
#define SUFFIX_THREADS	    "t"
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0"
        BEGIN
            VALUE "FileDescription", "Tclsh Application\0"
            VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"
            VALUE "CompanyName", "ActiveState Corporation\0"
            VALUE "FileVersion", TCL_PATCH_LEVEL
            VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0"
            VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
            VALUE "ProductVersion", TCL_PATCH_LEVEL
        END
    END







|







46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
 FILESUBTYPE 	0x0L
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040904b0"
        BEGIN
            VALUE "FileDescription", "Tclsh Application\0"
            VALUE "OriginalFilename", "tclsh" STRINGIFY(JOIN(TCL_MAJOR_VERSION,TCL_MINOR_VERSION)) SUFFIX ".exe\0"
            VALUE "CompanyName", "ActiveState Corporation\0"
            VALUE "FileVersion", TCL_PATCH_LEVEL
            VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0"
            VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
            VALUE "ProductVersion", TCL_PATCH_LEVEL
        END
    END